gcc/ada/sem_ch6.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C H 6                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Expander; use Expander;
  33 with Exp_Ch6;  use Exp_Ch6;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Ch9;  use Exp_Ch9;
  36 with Exp_Disp; use Exp_Disp;
  37 with Exp_Tss;  use Exp_Tss;
  38 with Exp_Util; use Exp_Util;
  39 with Fname;    use Fname;
  40 with Freeze;   use Freeze;
  41 with Itypes;   use Itypes;
  42 with Lib.Xref; use Lib.Xref;
  43 with Layout;   use Layout;
  44 with Namet;    use Namet;
  45 with Lib;      use Lib;
  46 with Nlists;   use Nlists;
  47 with Nmake;    use Nmake;
  48 with Opt;      use Opt;
  49 with Output;   use Output;
  50 with Restrict; use Restrict;
  51 with Rident;   use Rident;
  52 with Rtsfind;  use Rtsfind;
  53 with Sem;      use Sem;
  54 with Sem_Aux;  use Sem_Aux;
  55 with Sem_Cat;  use Sem_Cat;
  56 with Sem_Ch3;  use Sem_Ch3;
  57 with Sem_Ch4;  use Sem_Ch4;
  58 with Sem_Ch5;  use Sem_Ch5;
  59 with Sem_Ch8;  use Sem_Ch8;
  60 with Sem_Ch10; use Sem_Ch10;
  61 with Sem_Ch12; use Sem_Ch12;
  62 with Sem_Ch13; use Sem_Ch13;
  63 with Sem_Disp; use Sem_Disp;
  64 with Sem_Dist; use Sem_Dist;
  65 with Sem_Elim; use Sem_Elim;
  66 with Sem_Eval; use Sem_Eval;
  67 with Sem_Mech; use Sem_Mech;
  68 with Sem_Prag; use Sem_Prag;
  69 with Sem_Res;  use Sem_Res;
  70 with Sem_Util; use Sem_Util;
  71 with Sem_Type; use Sem_Type;
  72 with Sem_Warn; use Sem_Warn;
  73 with Sinput;   use Sinput;
  74 with Stand;    use Stand;
  75 with Sinfo;    use Sinfo;
  76 with Sinfo.CN; use Sinfo.CN;
  77 with Snames;   use Snames;
  78 with Stringt;  use Stringt;
  79 with Style;
  80 with Stylesw;  use Stylesw;
  81 with Tbuild;   use Tbuild;
  82 with Uintp;    use Uintp;
  83 with Urealp;   use Urealp;
  84 with Validsw;  use Validsw;
  85
  86 package body Sem_Ch6 is
  87
  88    May_Hide_Profile : Boolean := False;
  89    --  This flag is used to indicate that two formals in two subprograms being
  90    --  checked for conformance differ only in that one is an access parameter
  91    --  while the other is of a general access type with the same designated
  92    --  type. In this case, if the rest of the signatures match, a call to
  93    --  either subprogram may be ambiguous, which is worth a warning. The flag
  94    --  is set in Compatible_Types, and the warning emitted in
  95    --  New_Overloaded_Entity.
  96
  97    -----------------------
  98    -- Local Subprograms --
  99    -----------------------
 100
 101    procedure Analyze_Return_Statement (N : Node_Id);
 102    --  Common processing for simple and extended return statements
 103
 104    procedure Analyze_Function_Return (N : Node_Id);
 105    --  Subsidiary to Analyze_Return_Statement. Called when the return statement
 106    --  applies to a [generic] function.
 107
 108    procedure Analyze_Return_Type (N : Node_Id);
 109    --  Subsidiary to Process_Formals: analyze subtype mark in function
 110    --  specification in a context where the formals are visible and hide
 111    --  outer homographs.
 112
 113    procedure Analyze_Subprogram_Body_Helper (N : Node_Id);
 114    --  Does all the real work of Analyze_Subprogram_Body. This is split out so
 115    --  that we can use RETURN but not skip the debug output at the end.
 116
 117    procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
 118    --  Analyze a generic subprogram body. N is the body to be analyzed, and
 119    --  Gen_Id is the defining entity Id for the corresponding spec.
 120
 121    procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
 122    --  If a subprogram has pragma Inline and inlining is active, use generic
 123    --  machinery to build an unexpanded body for the subprogram. This body is
 124    --  subsequently used for inline expansions at call sites. If subprogram can
 125    --  be inlined (depending on size and nature of local declarations) this
 126    --  function returns true. Otherwise subprogram body is treated normally.
 127    --  If proper warnings are enabled and the subprogram contains a construct
 128    --  that cannot be inlined, the offending construct is flagged accordingly.
 129
 130    function Can_Override_Operator (Subp : Entity_Id) return Boolean;
 131    --  Returns true if Subp can override a predefined operator.
 132
 133    procedure Check_Conformance
 134      (New_Id                   : Entity_Id;
 135       Old_Id                   : Entity_Id;
 136       Ctype                    : Conformance_Type;
 137       Errmsg                   : Boolean;
 138       Conforms                 : out Boolean;
 139       Err_Loc                  : Node_Id := Empty;
 140       Get_Inst                 : Boolean := False;
 141       Skip_Controlling_Formals : Boolean := False);
 142    --  Given two entities, this procedure checks that the profiles associated
 143    --  with these entities meet the conformance criterion given by the third
 144    --  parameter. If they conform, Conforms is set True and control returns
 145    --  to the caller. If they do not conform, Conforms is set to False, and
 146    --  in addition, if Errmsg is True on the call, proper messages are output
 147    --  to complain about the conformance failure. If Err_Loc is non_Empty
 148    --  the error messages are placed on Err_Loc, if Err_Loc is empty, then
 149    --  error messages are placed on the appropriate part of the construct
 150    --  denoted by New_Id. If Get_Inst is true, then this is a mode conformance
 151    --  against a formal access-to-subprogram type so Get_Instance_Of must
 152    --  be called.
 153
 154    procedure Check_Subprogram_Order (N : Node_Id);
 155    --  N is the N_Subprogram_Body node for a subprogram. This routine applies
 156    --  the alpha ordering rule for N if this ordering requirement applicable.
 157
 158    procedure Check_Returns
 159      (HSS  : Node_Id;
 160       Mode : Character;
 161       Err  : out Boolean;
 162       Proc : Entity_Id := Empty);
 163    --  Called to check for missing return statements in a function body, or for
 164    --  returns present in a procedure body which has No_Return set. HSS is the
 165    --  handled statement sequence for the subprogram body. This procedure
 166    --  checks all flow paths to make sure they either have return (Mode = 'F',
 167    --  used for functions) or do not have a return (Mode = 'P', used for
 168    --  No_Return procedures). The flag Err is set if there are any control
 169    --  paths not explicitly terminated by a return in the function case, and is
 170    --  True otherwise. Proc is the entity for the procedure case and is used
 171    --  in posting the warning message.
 172
 173    procedure Check_Untagged_Equality (Eq_Op : Entity_Id);
 174    --  In Ada 2012, a primitive equality operator on an untagged record type
 175    --  must appear before the type is frozen, and have the same visibility as
 176    --  that of the type. This procedure checks that this rule is met, and
 177    --  otherwise emits an error on the subprogram declaration and a warning
 178    --  on the earlier freeze point if it is easy to locate.
 179
 180    procedure Enter_Overloaded_Entity (S : Entity_Id);
 181    --  This procedure makes S, a new overloaded entity, into the first visible
 182    --  entity with that name.
 183
 184    procedure Install_Entity (E : Entity_Id);
 185    --  Make single entity visible (used for generic formals as well)
 186
 187    function Is_Non_Overriding_Operation
 188      (Prev_E : Entity_Id;
 189       New_E  : Entity_Id) return Boolean;
 190    --  Enforce the rule given in 12.3(18): a private operation in an instance
 191    --  overrides an inherited operation only if the corresponding operation
 192    --  was overriding in the generic. This can happen for primitive operations
 193    --  of types derived (in the generic unit) from formal private or formal
 194    --  derived types.
 195
 196    procedure Make_Inequality_Operator (S : Entity_Id);
 197    --  Create the declaration for an inequality operator that is implicitly
 198    --  created by a user-defined equality operator that yields a boolean.
 199
 200    procedure May_Need_Actuals (Fun : Entity_Id);
 201    --  Flag functions that can be called without parameters, i.e. those that
 202    --  have no parameters, or those for which defaults exist for all parameters
 203
 204    procedure Process_PPCs
 205      (N       : Node_Id;
 206       Spec_Id : Entity_Id;
 207       Body_Id : Entity_Id);
 208    --  Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post
 209    --  conditions for the body and assembling and inserting the _postconditions
 210    --  procedure. N is the node for the subprogram body and Body_Id/Spec_Id are
 211    --  the entities for the body and separate spec (if there is no separate
 212    --  spec, Spec_Id is Empty). Note that invariants and predicates may also
 213    --  provide postconditions, and are also handled in this procedure.
 214
 215    procedure Set_Formal_Validity (Formal_Id : Entity_Id);
 216    --  Formal_Id is an formal parameter entity. This procedure deals with
 217    --  setting the proper validity status for this entity, which depends on
 218    --  the kind of parameter and the validity checking mode.
 219
 220    ---------------------------------------------
 221    -- Analyze_Abstract_Subprogram_Declaration --
 222    ---------------------------------------------
 223
 224    procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
 225       Designator : constant Entity_Id :=
 226                      Analyze_Subprogram_Specification (Specification (N));
 227       Scop       : constant Entity_Id := Current_Scope;
 228
 229    begin
 230       Check_SPARK_Restriction ("abstract subprogram is not allowed", N);
 231
 232       Generate_Definition (Designator);
 233       Set_Contract (Designator, Make_Contract (Sloc (Designator)));
 234       Set_Is_Abstract_Subprogram (Designator);
 235       New_Overloaded_Entity (Designator);
 236       Check_Delayed_Subprogram (Designator);
 237
 238       Set_Categorization_From_Scope (Designator, Scop);
 239
 240       if Ekind (Scope (Designator)) = E_Protected_Type then
 241          Error_Msg_N
 242            ("abstract subprogram not allowed in protected type", N);
 243
 244       --  Issue a warning if the abstract subprogram is neither a dispatching
 245       --  operation nor an operation that overrides an inherited subprogram or
 246       --  predefined operator, since this most likely indicates a mistake.
 247
 248       elsif Warn_On_Redundant_Constructs
 249         and then not Is_Dispatching_Operation (Designator)
 250         and then not Present (Overridden_Operation (Designator))
 251         and then (not Is_Operator_Symbol_Name (Chars (Designator))
 252                    or else Scop /= Scope (Etype (First_Formal (Designator))))
 253       then
 254          Error_Msg_N
 255            ("?abstract subprogram is not dispatching or overriding", N);
 256       end if;
 257
 258       Generate_Reference_To_Formals (Designator);
 259       Check_Eliminated (Designator);
 260
 261       if Has_Aspects (N) then
 262          Analyze_Aspect_Specifications (N, Designator);
 263       end if;
 264    end Analyze_Abstract_Subprogram_Declaration;
 265
 266    ---------------------------------
 267    -- Analyze_Expression_Function --
 268    ---------------------------------
 269
 270    procedure Analyze_Expression_Function (N : Node_Id) is
 271       Loc      : constant Source_Ptr := Sloc (N);
 272       LocX     : constant Source_Ptr := Sloc (Expression (N));
 273       Def_Id   : constant Entity_Id  := Defining_Entity (Specification (N));
 274       New_Body : Node_Id;
 275       New_Decl : Node_Id;
 276
 277       Prev : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
 278       --  If the expression is a completion, Prev is the entity whose
 279       --  declaration is completed.
 280
 281    begin
 282       --  This is one of the occasions on which we transform the tree during
 283       --  semantic analysis. If this is a completion, transform the expression
 284       --  function into an equivalent subprogram body, and analyze it.
 285
 286       --  Expression functions are inlined unconditionally. The back-end will
 287       --  determine whether this is possible.
 288
 289       Inline_Processing_Required := True;
 290
 291       New_Body :=
 292         Make_Subprogram_Body (Loc,
 293           Specification              => Specification (N),
 294           Declarations               => Empty_List,
 295           Handled_Statement_Sequence =>
 296             Make_Handled_Sequence_Of_Statements (LocX,
 297               Statements => New_List (
 298                 Make_Simple_Return_Statement (LocX,
 299                   Expression => Expression (N)))));
 300
 301       if Present (Prev)
 302         and then Ekind (Prev) = E_Generic_Function
 303       then
 304          --  If the expression completes a generic subprogram, we must create a
 305          --  separate node for the body, because at instantiation the original
 306          --  node of the generic copy must be a generic subprogram body, and
 307          --  cannot be a expression function. Otherwise we just rewrite the
 308          --  expression with the non-generic body.
 309
 310          Insert_After (N, New_Body);
 311          Rewrite (N, Make_Null_Statement (Loc));
 312          Analyze (N);
 313          Analyze (New_Body);
 314          Set_Is_Inlined (Prev);
 315
 316       elsif Present (Prev) then
 317          Rewrite (N, New_Body);
 318          Set_Is_Inlined (Prev);
 319          Analyze (N);
 320
 321       --  If this is not a completion, create both a declaration and a body,
 322       --  so that the expression can be inlined whenever possible.
 323
 324       else
 325          New_Decl :=
 326            Make_Subprogram_Declaration (Loc,
 327              Specification => Specification (N));
 328          Rewrite (N, New_Decl);
 329          Analyze (N);
 330          Set_Is_Inlined (Defining_Entity (New_Decl));
 331
 332          --  Create new set of formals for specification in body.
 333
 334          Set_Specification (New_Body,
 335            Make_Function_Specification (Loc,
 336              Defining_Unit_Name =>
 337                Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))),
 338              Parameter_Specifications =>
 339                Copy_Parameter_List (Defining_Entity (New_Decl)),
 340              Result_Definition =>
 341                New_Copy_Tree (Result_Definition (Specification (New_Decl)))));
 342
 343          Insert_After (N, New_Body);
 344          Analyze (New_Body);
 345       end if;
 346    end Analyze_Expression_Function;
 347
 348    ----------------------------------------
 349    -- Analyze_Extended_Return_Statement  --
 350    ----------------------------------------
 351
 352    procedure Analyze_Extended_Return_Statement (N : Node_Id) is
 353    begin
 354       Analyze_Return_Statement (N);
 355    end Analyze_Extended_Return_Statement;
 356
 357    ----------------------------
 358    -- Analyze_Function_Call  --
 359    ----------------------------
 360
 361    procedure Analyze_Function_Call (N : Node_Id) is
 362       P       : constant Node_Id := Name (N);
 363       Actuals : constant List_Id := Parameter_Associations (N);
 364       Actual  : Node_Id;
 365
 366    begin
 367       Analyze (P);
 368
 369       --  A call of the form A.B (X) may be an Ada05 call, which is rewritten
 370       --  as B (A, X). If the rewriting is successful, the call has been
 371       --  analyzed and we just return.
 372
 373       if Nkind (P) = N_Selected_Component
 374         and then Name (N) /= P
 375         and then Is_Rewrite_Substitution (N)
 376         and then Present (Etype (N))
 377       then
 378          return;
 379       end if;
 380
 381       --  If error analyzing name, then set Any_Type as result type and return
 382
 383       if Etype (P) = Any_Type then
 384          Set_Etype (N, Any_Type);
 385          return;
 386       end if;
 387
 388       --  Otherwise analyze the parameters
 389
 390       if Present (Actuals) then
 391          Actual := First (Actuals);
 392          while Present (Actual) loop
 393             Analyze (Actual);
 394             Check_Parameterless_Call (Actual);
 395             Next (Actual);
 396          end loop;
 397       end if;
 398
 399       Analyze_Call (N);
 400    end Analyze_Function_Call;
 401
 402    -----------------------------
 403    -- Analyze_Function_Return --
 404    -----------------------------
 405
 406    procedure Analyze_Function_Return (N : Node_Id) is
 407       Loc        : constant Source_Ptr  := Sloc (N);
 408       Stm_Entity : constant Entity_Id   := Return_Statement_Entity (N);
 409       Scope_Id   : constant Entity_Id   := Return_Applies_To (Stm_Entity);
 410
 411       R_Type : constant Entity_Id := Etype (Scope_Id);
 412       --  Function result subtype
 413
 414       procedure Check_Limited_Return (Expr : Node_Id);
 415       --  Check the appropriate (Ada 95 or Ada 2005) rules for returning
 416       --  limited types. Used only for simple return statements.
 417       --  Expr is the expression returned.
 418
 419       procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
 420       --  Check that the return_subtype_indication properly matches the result
 421       --  subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
 422
 423       --------------------------
 424       -- Check_Limited_Return --
 425       --------------------------
 426
 427       procedure Check_Limited_Return (Expr : Node_Id) is
 428       begin
 429          --  Ada 2005 (AI-318-02): Return-by-reference types have been
 430          --  removed and replaced by anonymous access results. This is an
 431          --  incompatibility with Ada 95. Not clear whether this should be
 432          --  enforced yet or perhaps controllable with special switch. ???
 433
 434          if Is_Limited_Type (R_Type)
 435            and then Comes_From_Source (N)
 436            and then not In_Instance_Body
 437            and then not OK_For_Limited_Init_In_05 (R_Type, Expr)
 438          then
 439             --  Error in Ada 2005
 440
 441             if Ada_Version >= Ada_2005
 442               and then not Debug_Flag_Dot_L
 443               and then not GNAT_Mode
 444             then
 445                Error_Msg_N
 446                  ("(Ada 2005) cannot copy object of a limited type " &
 447                   "(RM-2005 6.5(5.5/2))", Expr);
 448
 449                if Is_Immutably_Limited_Type (R_Type) then
 450                   Error_Msg_N
 451                     ("\return by reference not permitted in Ada 2005", Expr);
 452                end if;
 453
 454             --  Warn in Ada 95 mode, to give folks a heads up about this
 455             --  incompatibility.
 456
 457             --  In GNAT mode, this is just a warning, to allow it to be
 458             --  evilly turned off. Otherwise it is a real error.
 459
 460             --  In a generic context, simplify the warning because it makes
 461             --  no sense to discuss pass-by-reference or copy.
 462
 463             elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
 464                if Inside_A_Generic then
 465                   Error_Msg_N
 466                     ("return of limited object not permitted in Ada2005 "
 467                      & "(RM-2005 6.5(5.5/2))?", Expr);
 468
 469                elsif Is_Immutably_Limited_Type (R_Type) then
 470                   Error_Msg_N
 471                     ("return by reference not permitted in Ada 2005 "
 472                      & "(RM-2005 6.5(5.5/2))?", Expr);
 473                else
 474                   Error_Msg_N
 475                     ("cannot copy object of a limited type in Ada 2005 "
 476                      & "(RM-2005 6.5(5.5/2))?", Expr);
 477                end if;
 478
 479             --  Ada 95 mode, compatibility warnings disabled
 480
 481             else
 482                return; --  skip continuation messages below
 483             end if;
 484
 485             if not Inside_A_Generic then
 486                Error_Msg_N
 487                  ("\consider switching to return of access type", Expr);
 488                Explain_Limited_Type (R_Type, Expr);
 489             end if;
 490          end if;
 491       end Check_Limited_Return;
 492
 493       -------------------------------------
 494       -- Check_Return_Subtype_Indication --
 495       -------------------------------------
 496
 497       procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
 498          Return_Obj : constant Node_Id   := Defining_Identifier (Obj_Decl);
 499
 500          R_Stm_Type : constant Entity_Id := Etype (Return_Obj);
 501          --  Subtype given in the extended return statement (must match R_Type)
 502
 503          Subtype_Ind : constant Node_Id :=
 504                          Object_Definition (Original_Node (Obj_Decl));
 505
 506          R_Type_Is_Anon_Access :
 507            constant Boolean :=
 508              Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
 509                or else
 510              Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
 511                or else
 512              Ekind (R_Type) = E_Anonymous_Access_Type;
 513          --  True if return type of the function is an anonymous access type
 514          --  Can't we make Is_Anonymous_Access_Type in einfo ???
 515
 516          R_Stm_Type_Is_Anon_Access :
 517            constant Boolean :=
 518              Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
 519                or else
 520              Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
 521                or else
 522              Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
 523          --  True if type of the return object is an anonymous access type
 524
 525       begin
 526          --  First, avoid cascaded errors
 527
 528          if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then
 529             return;
 530          end if;
 531
 532          --  "return access T" case; check that the return statement also has
 533          --  "access T", and that the subtypes statically match:
 534          --   if this is an access to subprogram the signatures must match.
 535
 536          if R_Type_Is_Anon_Access then
 537             if R_Stm_Type_Is_Anon_Access then
 538                if
 539                  Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
 540                then
 541                   if Base_Type (Designated_Type (R_Stm_Type)) /=
 542                      Base_Type (Designated_Type (R_Type))
 543                     or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
 544                   then
 545                      Error_Msg_N
 546                       ("subtype must statically match function result subtype",
 547                        Subtype_Mark (Subtype_Ind));
 548                   end if;
 549
 550                else
 551                   --  For two anonymous access to subprogram types, the
 552                   --  types themselves must be type conformant.
 553
 554                   if not Conforming_Types
 555                     (R_Stm_Type, R_Type, Fully_Conformant)
 556                   then
 557                      Error_Msg_N
 558                       ("subtype must statically match function result subtype",
 559                          Subtype_Ind);
 560                   end if;
 561                end if;
 562
 563             else
 564                Error_Msg_N ("must use anonymous access type", Subtype_Ind);
 565             end if;
 566
 567          --  Subtype indication case: check that the return object's type is
 568          --  covered by the result type, and that the subtypes statically match
 569          --  when the result subtype is constrained. Also handle record types
 570          --  with unknown discriminants for which we have built the underlying
 571          --  record view. Coverage is needed to allow specific-type return
 572          --  objects when the result type is class-wide (see AI05-32).
 573
 574          elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type))
 575            or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type))
 576                      and then
 577                        Covers
 578                          (Base_Type (R_Type),
 579                           Underlying_Record_View (Base_Type (R_Stm_Type))))
 580          then
 581             --  A null exclusion may be present on the return type, on the
 582             --  function specification, on the object declaration or on the
 583             --  subtype itself.
 584
 585             if Is_Access_Type (R_Type)
 586               and then
 587                (Can_Never_Be_Null (R_Type)
 588                  or else Null_Exclusion_Present (Parent (Scope_Id))) /=
 589                                               Can_Never_Be_Null (R_Stm_Type)
 590             then
 591                Error_Msg_N
 592                  ("subtype must statically match function result subtype",
 593                   Subtype_Ind);
 594             end if;
 595
 596             --  AI05-103: for elementary types, subtypes must statically match
 597
 598             if Is_Constrained (R_Type)
 599               or else Is_Access_Type (R_Type)
 600             then
 601                if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
 602                   Error_Msg_N
 603                     ("subtype must statically match function result subtype",
 604                      Subtype_Ind);
 605                end if;
 606             end if;
 607
 608          elsif Etype (Base_Type (R_Type)) = R_Stm_Type
 609            and then Is_Null_Extension (Base_Type (R_Type))
 610          then
 611             null;
 612
 613          else
 614             Error_Msg_N
 615               ("wrong type for return_subtype_indication", Subtype_Ind);
 616          end if;
 617       end Check_Return_Subtype_Indication;
 618
 619       ---------------------
 620       -- Local Variables --
 621       ---------------------
 622
 623       Expr : Node_Id;
 624
 625    --  Start of processing for Analyze_Function_Return
 626
 627    begin
 628       Set_Return_Present (Scope_Id);
 629
 630       if Nkind (N) = N_Simple_Return_Statement then
 631          Expr := Expression (N);
 632
 633          --  Guard against a malformed expression. The parser may have tried to
 634          --  recover but the node is not analyzable.
 635
 636          if Nkind (Expr) = N_Error then
 637             Set_Etype (Expr, Any_Type);
 638             Expander_Mode_Save_And_Set (False);
 639             return;
 640
 641          else
 642             --  The resolution of a controlled [extension] aggregate associated
 643             --  with a return statement creates a temporary which needs to be
 644             --  finalized on function exit. Wrap the return statement inside a
 645             --  block so that the finalization machinery can detect this case.
 646             --  This early expansion is done only when the return statement is
 647             --  not part of a handled sequence of statements.
 648
 649             if Nkind_In (Expr, N_Aggregate,
 650                                N_Extension_Aggregate)
 651               and then Needs_Finalization (R_Type)
 652               and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
 653             then
 654                Rewrite (N,
 655                  Make_Block_Statement (Loc,
 656                    Handled_Statement_Sequence =>
 657                      Make_Handled_Sequence_Of_Statements (Loc,
 658                        Statements => New_List (Relocate_Node (N)))));
 659
 660                Analyze (N);
 661                return;
 662             end if;
 663
 664             Analyze_And_Resolve (Expr, R_Type);
 665             Check_Limited_Return (Expr);
 666          end if;
 667
 668          --  RETURN only allowed in SPARK as the last statement in function
 669
 670          if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
 671            and then
 672              (Nkind (Parent (Parent (N))) /= N_Subprogram_Body
 673                or else Present (Next (N)))
 674          then
 675             Check_SPARK_Restriction
 676               ("RETURN should be the last statement in function", N);
 677          end if;
 678
 679       else
 680          Check_SPARK_Restriction ("extended RETURN is not allowed", N);
 681
 682          --  Analyze parts specific to extended_return_statement:
 683
 684          declare
 685             Obj_Decl : constant Node_Id :=
 686                          Last (Return_Object_Declarations (N));
 687
 688             HSS : constant Node_Id := Handled_Statement_Sequence (N);
 689
 690          begin
 691             Expr := Expression (Obj_Decl);
 692
 693             --  Note: The check for OK_For_Limited_Init will happen in
 694             --  Analyze_Object_Declaration; we treat it as a normal
 695             --  object declaration.
 696
 697             Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
 698             Analyze (Obj_Decl);
 699
 700             Check_Return_Subtype_Indication (Obj_Decl);
 701
 702             if Present (HSS) then
 703                Analyze (HSS);
 704
 705                if Present (Exception_Handlers (HSS)) then
 706
 707                   --  ???Has_Nested_Block_With_Handler needs to be set.
 708                   --  Probably by creating an actual N_Block_Statement.
 709                   --  Probably in Expand.
 710
 711                   null;
 712                end if;
 713             end if;
 714
 715             --  Mark the return object as referenced, since the return is an
 716             --  implicit reference of the object.
 717
 718             Set_Referenced (Defining_Identifier (Obj_Decl));
 719
 720             Check_References (Stm_Entity);
 721          end;
 722       end if;
 723
 724       --  Case of Expr present
 725
 726       if Present (Expr)
 727
 728          --  Defend against previous errors
 729
 730         and then Nkind (Expr) /= N_Empty
 731         and then Present (Etype (Expr))
 732       then
 733          --  Apply constraint check. Note that this is done before the implicit
 734          --  conversion of the expression done for anonymous access types to
 735          --  ensure correct generation of the null-excluding check associated
 736          --  with null-excluding expressions found in return statements.
 737
 738          Apply_Constraint_Check (Expr, R_Type);
 739
 740          --  Ada 2005 (AI-318-02): When the result type is an anonymous access
 741          --  type, apply an implicit conversion of the expression to that type
 742          --  to force appropriate static and run-time accessibility checks.
 743
 744          if Ada_Version >= Ada_2005
 745            and then Ekind (R_Type) = E_Anonymous_Access_Type
 746          then
 747             Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
 748             Analyze_And_Resolve (Expr, R_Type);
 749          end if;
 750
 751          --  If the result type is class-wide, then check that the return
 752          --  expression's type is not declared at a deeper level than the
 753          --  function (RM05-6.5(5.6/2)).
 754
 755          if Ada_Version >= Ada_2005
 756            and then Is_Class_Wide_Type (R_Type)
 757          then
 758             if Type_Access_Level (Etype (Expr)) >
 759                  Subprogram_Access_Level (Scope_Id)
 760             then
 761                Error_Msg_N
 762                  ("level of return expression type is deeper than " &
 763                   "class-wide function!", Expr);
 764             end if;
 765          end if;
 766
 767          --  Check incorrect use of dynamically tagged expression
 768
 769          if Is_Tagged_Type (R_Type) then
 770             Check_Dynamically_Tagged_Expression
 771               (Expr => Expr,
 772                Typ  => R_Type,
 773                Related_Nod => N);
 774          end if;
 775
 776          --  ??? A real run-time accessibility check is needed in cases
 777          --  involving dereferences of access parameters. For now we just
 778          --  check the static cases.
 779
 780          if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
 781            and then Is_Immutably_Limited_Type (Etype (Scope_Id))
 782            and then Object_Access_Level (Expr) >
 783                       Subprogram_Access_Level (Scope_Id)
 784          then
 785
 786             --  Suppress the message in a generic, where the rewriting
 787             --  is irrelevant.
 788
 789             if Inside_A_Generic then
 790                null;
 791
 792             else
 793                Rewrite (N,
 794                  Make_Raise_Program_Error (Loc,
 795                    Reason => PE_Accessibility_Check_Failed));
 796                Analyze (N);
 797
 798                Error_Msg_N
 799                  ("cannot return a local value by reference?", N);
 800                Error_Msg_NE
 801                  ("\& will be raised at run time?",
 802                    N, Standard_Program_Error);
 803             end if;
 804          end if;
 805
 806          if Known_Null (Expr)
 807            and then Nkind (Parent (Scope_Id)) = N_Function_Specification
 808            and then Null_Exclusion_Present (Parent (Scope_Id))
 809          then
 810             Apply_Compile_Time_Constraint_Error
 811               (N      => Expr,
 812                Msg    => "(Ada 2005) null not allowed for "
 813                          & "null-excluding return?",
 814                Reason => CE_Null_Not_Allowed);
 815          end if;
 816
 817          --  Apply checks suggested by AI05-0144 (dangerous order dependence)
 818
 819          Check_Order_Dependence;
 820       end if;
 821    end Analyze_Function_Return;
 822
 823    -------------------------------------
 824    -- Analyze_Generic_Subprogram_Body --
 825    -------------------------------------
 826
 827    procedure Analyze_Generic_Subprogram_Body
 828      (N      : Node_Id;
 829       Gen_Id : Entity_Id)
 830    is
 831       Gen_Decl : constant Node_Id     := Unit_Declaration_Node (Gen_Id);
 832       Kind     : constant Entity_Kind := Ekind (Gen_Id);
 833       Body_Id  : Entity_Id;
 834       New_N    : Node_Id;
 835       Spec     : Node_Id;
 836
 837    begin
 838       --  Copy body and disable expansion while analyzing the generic For a
 839       --  stub, do not copy the stub (which would load the proper body), this
 840       --  will be done when the proper body is analyzed.
 841
 842       if Nkind (N) /= N_Subprogram_Body_Stub then
 843          New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
 844          Rewrite (N, New_N);
 845          Start_Generic;
 846       end if;
 847
 848       Spec := Specification (N);
 849
 850       --  Within the body of the generic, the subprogram is callable, and
 851       --  behaves like the corresponding non-generic unit.
 852
 853       Body_Id := Defining_Entity (Spec);
 854
 855       if Kind = E_Generic_Procedure
 856         and then Nkind (Spec) /= N_Procedure_Specification
 857       then
 858          Error_Msg_N ("invalid body for generic procedure ", Body_Id);
 859          return;
 860
 861       elsif Kind = E_Generic_Function
 862         and then Nkind (Spec) /= N_Function_Specification
 863       then
 864          Error_Msg_N ("invalid body for generic function ", Body_Id);
 865          return;
 866       end if;
 867
 868       Set_Corresponding_Body (Gen_Decl, Body_Id);
 869
 870       if Has_Completion (Gen_Id)
 871         and then Nkind (Parent (N)) /= N_Subunit
 872       then
 873          Error_Msg_N ("duplicate generic body", N);
 874          return;
 875       else
 876          Set_Has_Completion (Gen_Id);
 877       end if;
 878
 879       if Nkind (N) = N_Subprogram_Body_Stub then
 880          Set_Ekind (Defining_Entity (Specification (N)), Kind);
 881       else
 882          Set_Corresponding_Spec (N, Gen_Id);
 883       end if;
 884
 885       if Nkind (Parent (N)) = N_Compilation_Unit then
 886          Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
 887       end if;
 888
 889       --  Make generic parameters immediately visible in the body. They are
 890       --  needed to process the formals declarations. Then make the formals
 891       --  visible in a separate step.
 892
 893       Push_Scope (Gen_Id);
 894
 895       declare
 896          E         : Entity_Id;
 897          First_Ent : Entity_Id;
 898
 899       begin
 900          First_Ent := First_Entity (Gen_Id);
 901
 902          E := First_Ent;
 903          while Present (E) and then not Is_Formal (E) loop
 904             Install_Entity (E);
 905             Next_Entity (E);
 906          end loop;
 907
 908          Set_Use (Generic_Formal_Declarations (Gen_Decl));
 909
 910          --  Now generic formals are visible, and the specification can be
 911          --  analyzed, for subsequent conformance check.
 912
 913          Body_Id := Analyze_Subprogram_Specification (Spec);
 914
 915          --  Make formal parameters visible
 916
 917          if Present (E) then
 918
 919             --  E is the first formal parameter, we loop through the formals
 920             --  installing them so that they will be visible.
 921
 922             Set_First_Entity (Gen_Id, E);
 923             while Present (E) loop
 924                Install_Entity (E);
 925                Next_Formal (E);
 926             end loop;
 927          end if;
 928
 929          --  Visible generic entity is callable within its own body
 930
 931          Set_Ekind          (Gen_Id,  Ekind (Body_Id));
 932          Set_Ekind          (Body_Id, E_Subprogram_Body);
 933          Set_Convention     (Body_Id, Convention (Gen_Id));
 934          Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
 935          Set_Scope          (Body_Id, Scope (Gen_Id));
 936          Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
 937
 938          if Nkind (N) = N_Subprogram_Body_Stub then
 939
 940             --  No body to analyze, so restore state of generic unit
 941
 942             Set_Ekind (Gen_Id, Kind);
 943             Set_Ekind (Body_Id, Kind);
 944
 945             if Present (First_Ent) then
 946                Set_First_Entity (Gen_Id, First_Ent);
 947             end if;
 948
 949             End_Scope;
 950             return;
 951          end if;
 952
 953          --  If this is a compilation unit, it must be made visible explicitly,
 954          --  because the compilation of the declaration, unlike other library
 955          --  unit declarations, does not. If it is not a unit, the following
 956          --  is redundant but harmless.
 957
 958          Set_Is_Immediately_Visible (Gen_Id);
 959          Reference_Body_Formals (Gen_Id, Body_Id);
 960
 961          if Is_Child_Unit (Gen_Id) then
 962             Generate_Reference (Gen_Id, Scope (Gen_Id), 'k', False);
 963          end if;
 964
 965          Set_Actual_Subtypes (N, Current_Scope);
 966
 967          --  Deal with preconditions and postconditions. In formal verification
 968          --  mode, we keep pre- and postconditions attached to entities rather
 969          --  than inserted in the code, in order to facilitate a distinct
 970          --  treatment for them.
 971
 972          if not ALFA_Mode then
 973             Process_PPCs (N, Gen_Id, Body_Id);
 974          end if;
 975
 976          --  If the generic unit carries pre- or post-conditions, copy them
 977          --  to the original generic tree, so that they are properly added
 978          --  to any instantiation.
 979
 980          declare
 981             Orig : constant Node_Id := Original_Node (N);
 982             Cond : Node_Id;
 983
 984          begin
 985             Cond := First (Declarations (N));
 986             while Present (Cond) loop
 987                if Nkind (Cond) = N_Pragma
 988                  and then Pragma_Name (Cond) = Name_Check
 989                then
 990                   Prepend (New_Copy_Tree (Cond), Declarations (Orig));
 991
 992                elsif Nkind (Cond) = N_Pragma
 993                  and then Pragma_Name (Cond) = Name_Postcondition
 994                then
 995                   Set_Ekind (Defining_Entity (Orig), Ekind (Gen_Id));
 996                   Prepend (New_Copy_Tree (Cond), Declarations (Orig));
 997                else
 998                   exit;
 999                end if;
1000
1001                Next (Cond);
1002             end loop;
1003          end;
1004
1005          Analyze_Declarations (Declarations (N));
1006          Check_Completion;
1007          Analyze (Handled_Statement_Sequence (N));
1008
1009          Save_Global_References (Original_Node (N));
1010
1011          --  Prior to exiting the scope, include generic formals again (if any
1012          --  are present) in the set of local entities.
1013
1014          if Present (First_Ent) then
1015             Set_First_Entity (Gen_Id, First_Ent);
1016          end if;
1017
1018          Check_References (Gen_Id);
1019       end;
1020
1021       Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
1022       End_Scope;
1023       Check_Subprogram_Order (N);
1024
1025       --  Outside of its body, unit is generic again
1026
1027       Set_Ekind (Gen_Id, Kind);
1028       Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
1029
1030       if Style_Check then
1031          Style.Check_Identifier (Body_Id, Gen_Id);
1032       end if;
1033
1034       End_Generic;
1035    end Analyze_Generic_Subprogram_Body;
1036
1037    -----------------------------
1038    -- Analyze_Operator_Symbol --
1039    -----------------------------
1040
1041    --  An operator symbol such as "+" or "and" may appear in context where the
1042    --  literal denotes an entity name, such as "+"(x, y) or in context when it
1043    --  is just a string, as in (conjunction = "or"). In these cases the parser
1044    --  generates this node, and the semantics does the disambiguation. Other
1045    --  such case are actuals in an instantiation, the generic unit in an
1046    --  instantiation, and pragma arguments.
1047
1048    procedure Analyze_Operator_Symbol (N : Node_Id) is
1049       Par : constant Node_Id := Parent (N);
1050
1051    begin
1052       if        (Nkind (Par) = N_Function_Call
1053                    and then N = Name (Par))
1054         or else  Nkind (Par) = N_Function_Instantiation
1055         or else (Nkind (Par) = N_Indexed_Component
1056                    and then N = Prefix (Par))
1057         or else (Nkind (Par) = N_Pragma_Argument_Association
1058                    and then not Is_Pragma_String_Literal (Par))
1059         or else  Nkind (Par) = N_Subprogram_Renaming_Declaration
1060         or else (Nkind (Par) = N_Attribute_Reference
1061                   and then Attribute_Name (Par) /= Name_Value)
1062       then
1063          Find_Direct_Name (N);
1064
1065       else
1066          Change_Operator_Symbol_To_String_Literal (N);
1067          Analyze (N);
1068       end if;
1069    end Analyze_Operator_Symbol;
1070
1071    -----------------------------------
1072    -- Analyze_Parameter_Association --
1073    -----------------------------------
1074
1075    procedure Analyze_Parameter_Association (N : Node_Id) is
1076    begin
1077       Analyze (Explicit_Actual_Parameter (N));
1078    end Analyze_Parameter_Association;
1079
1080    ----------------------------
1081    -- Analyze_Procedure_Call --
1082    ----------------------------
1083
1084    procedure Analyze_Procedure_Call (N : Node_Id) is
1085       Loc     : constant Source_Ptr := Sloc (N);
1086       P       : constant Node_Id    := Name (N);
1087       Actuals : constant List_Id    := Parameter_Associations (N);
1088       Actual  : Node_Id;
1089       New_N   : Node_Id;
1090
1091       procedure Analyze_Call_And_Resolve;
1092       --  Do Analyze and Resolve calls for procedure call
1093       --  At end, check illegal order dependence.
1094
1095       ------------------------------
1096       -- Analyze_Call_And_Resolve --
1097       ------------------------------
1098
1099       procedure Analyze_Call_And_Resolve is
1100       begin
1101          if Nkind (N) = N_Procedure_Call_Statement then
1102             Analyze_Call (N);
1103             Resolve (N, Standard_Void_Type);
1104
1105             --  Apply checks suggested by AI05-0144
1106
1107             Check_Order_Dependence;
1108
1109          else
1110             Analyze (N);
1111          end if;
1112       end Analyze_Call_And_Resolve;
1113
1114    --  Start of processing for Analyze_Procedure_Call
1115
1116    begin
1117       --  The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
1118       --  a procedure call or an entry call. The prefix may denote an access
1119       --  to subprogram type, in which case an implicit dereference applies.
1120       --  If the prefix is an indexed component (without implicit dereference)
1121       --  then the construct denotes a call to a member of an entire family.
1122       --  If the prefix is a simple name, it may still denote a call to a
1123       --  parameterless member of an entry family. Resolution of these various
1124       --  interpretations is delicate.
1125
1126       Analyze (P);
1127
1128       --  If this is a call of the form Obj.Op, the call may have been
1129       --  analyzed and possibly rewritten into a block, in which case
1130       --  we are done.
1131
1132       if Analyzed (N) then
1133          return;
1134       end if;
1135
1136       --  If there is an error analyzing the name (which may have been
1137       --  rewritten if the original call was in prefix notation) then error
1138       --  has been emitted already, mark node and return.
1139
1140       if Error_Posted (N)
1141         or else Etype (Name (N)) = Any_Type
1142       then
1143          Set_Etype (N, Any_Type);
1144          return;
1145       end if;
1146
1147       --  Otherwise analyze the parameters
1148
1149       if Present (Actuals) then
1150          Actual := First (Actuals);
1151
1152          while Present (Actual) loop
1153             Analyze (Actual);
1154             Check_Parameterless_Call (Actual);
1155             Next (Actual);
1156          end loop;
1157       end if;
1158
1159       --  Special processing for Elab_Spec and Elab_Body calls
1160
1161       if Nkind (P) = N_Attribute_Reference
1162         and then (Attribute_Name (P) = Name_Elab_Spec
1163                    or else Attribute_Name (P) = Name_Elab_Body)
1164       then
1165          if Present (Actuals) then
1166             Error_Msg_N
1167               ("no parameters allowed for this call", First (Actuals));
1168             return;
1169          end if;
1170
1171          Set_Etype (N, Standard_Void_Type);
1172          Set_Analyzed (N);
1173
1174       elsif Is_Entity_Name (P)
1175         and then Is_Record_Type (Etype (Entity (P)))
1176         and then Remote_AST_I_Dereference (P)
1177       then
1178          return;
1179
1180       elsif Is_Entity_Name (P)
1181         and then Ekind (Entity (P)) /= E_Entry_Family
1182       then
1183          if Is_Access_Type (Etype (P))
1184            and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1185            and then No (Actuals)
1186            and then Comes_From_Source (N)
1187          then
1188             Error_Msg_N ("missing explicit dereference in call", N);
1189          end if;
1190
1191          Analyze_Call_And_Resolve;
1192
1193       --  If the prefix is the simple name of an entry family, this is
1194       --  a parameterless call from within the task body itself.
1195
1196       elsif Is_Entity_Name (P)
1197         and then Nkind (P) = N_Identifier
1198         and then Ekind (Entity (P)) = E_Entry_Family
1199         and then Present (Actuals)
1200         and then No (Next (First (Actuals)))
1201       then
1202          --  Can be call to parameterless entry family. What appears to be the
1203          --  sole argument is in fact the entry index. Rewrite prefix of node
1204          --  accordingly. Source representation is unchanged by this
1205          --  transformation.
1206
1207          New_N :=
1208            Make_Indexed_Component (Loc,
1209              Prefix =>
1210                Make_Selected_Component (Loc,
1211                  Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
1212                  Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
1213              Expressions => Actuals);
1214          Set_Name (N, New_N);
1215          Set_Etype (New_N, Standard_Void_Type);
1216          Set_Parameter_Associations (N, No_List);
1217          Analyze_Call_And_Resolve;
1218
1219       elsif Nkind (P) = N_Explicit_Dereference then
1220          if Ekind (Etype (P)) = E_Subprogram_Type then
1221             Analyze_Call_And_Resolve;
1222          else
1223             Error_Msg_N ("expect access to procedure in call", P);
1224          end if;
1225
1226       --  The name can be a selected component or an indexed component that
1227       --  yields an access to subprogram. Such a prefix is legal if the call
1228       --  has parameter associations.
1229
1230       elsif Is_Access_Type (Etype (P))
1231         and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
1232       then
1233          if Present (Actuals) then
1234             Analyze_Call_And_Resolve;
1235          else
1236             Error_Msg_N ("missing explicit dereference in call ", N);
1237          end if;
1238
1239       --  If not an access to subprogram, then the prefix must resolve to the
1240       --  name of an entry, entry family, or protected operation.
1241
1242       --  For the case of a simple entry call, P is a selected component where
1243       --  the prefix is the task and the selector name is the entry. A call to
1244       --  a protected procedure will have the same syntax. If the protected
1245       --  object contains overloaded operations, the entity may appear as a
1246       --  function, the context will select the operation whose type is Void.
1247
1248       elsif Nkind (P) = N_Selected_Component
1249         and then (Ekind (Entity (Selector_Name (P))) = E_Entry
1250                     or else
1251                   Ekind (Entity (Selector_Name (P))) = E_Procedure
1252                     or else
1253                   Ekind (Entity (Selector_Name (P))) = E_Function)
1254       then
1255          Analyze_Call_And_Resolve;
1256
1257       elsif Nkind (P) = N_Selected_Component
1258         and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
1259         and then Present (Actuals)
1260         and then No (Next (First (Actuals)))
1261       then
1262          --  Can be call to parameterless entry family. What appears to be the
1263          --  sole argument is in fact the entry index. Rewrite prefix of node
1264          --  accordingly. Source representation is unchanged by this
1265          --  transformation.
1266
1267          New_N :=
1268            Make_Indexed_Component (Loc,
1269              Prefix => New_Copy (P),
1270              Expressions => Actuals);
1271          Set_Name (N, New_N);
1272          Set_Etype (New_N, Standard_Void_Type);
1273          Set_Parameter_Associations (N, No_List);
1274          Analyze_Call_And_Resolve;
1275
1276       --  For the case of a reference to an element of an entry family, P is
1277       --  an indexed component whose prefix is a selected component (task and
1278       --  entry family), and whose index is the entry family index.
1279
1280       elsif Nkind (P) = N_Indexed_Component
1281         and then Nkind (Prefix (P)) = N_Selected_Component
1282         and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
1283       then
1284          Analyze_Call_And_Resolve;
1285
1286       --  If the prefix is the name of an entry family, it is a call from
1287       --  within the task body itself.
1288
1289       elsif Nkind (P) = N_Indexed_Component
1290         and then Nkind (Prefix (P)) = N_Identifier
1291         and then Ekind (Entity (Prefix (P))) = E_Entry_Family
1292       then
1293          New_N :=
1294            Make_Selected_Component (Loc,
1295              Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
1296              Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
1297          Rewrite (Prefix (P), New_N);
1298          Analyze (P);
1299          Analyze_Call_And_Resolve;
1300
1301       --  Anything else is an error
1302
1303       else
1304          Error_Msg_N ("invalid procedure or entry call", N);
1305       end if;
1306    end Analyze_Procedure_Call;
1307
1308    ------------------------------
1309    -- Analyze_Return_Statement --
1310    ------------------------------
1311
1312    procedure Analyze_Return_Statement (N : Node_Id) is
1313
1314       pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
1315                                   N_Extended_Return_Statement));
1316
1317       Returns_Object : constant Boolean :=
1318                          Nkind (N) = N_Extended_Return_Statement
1319                            or else
1320                             (Nkind (N) = N_Simple_Return_Statement
1321                               and then Present (Expression (N)));
1322       --  True if we're returning something; that is, "return <expression>;"
1323       --  or "return Result : T [:= ...]". False for "return;". Used for error
1324       --  checking: If Returns_Object is True, N should apply to a function
1325       --  body; otherwise N should apply to a procedure body, entry body,
1326       --  accept statement, or extended return statement.
1327
1328       function Find_What_It_Applies_To return Entity_Id;
1329       --  Find the entity representing the innermost enclosing body, accept
1330       --  statement, or extended return statement. If the result is a callable
1331       --  construct or extended return statement, then this will be the value
1332       --  of the Return_Applies_To attribute. Otherwise, the program is
1333       --  illegal. See RM-6.5(4/2).
1334
1335       -----------------------------
1336       -- Find_What_It_Applies_To --
1337       -----------------------------
1338
1339       function Find_What_It_Applies_To return Entity_Id is
1340          Result : Entity_Id := Empty;
1341
1342       begin
1343          --  Loop outward through the Scope_Stack, skipping blocks and loops
1344
1345          for J in reverse 0 .. Scope_Stack.Last loop
1346             Result := Scope_Stack.Table (J).Entity;
1347             exit when Ekind (Result) /= E_Block and then
1348                       Ekind (Result) /= E_Loop;
1349          end loop;
1350
1351          pragma Assert (Present (Result));
1352          return Result;
1353       end Find_What_It_Applies_To;
1354
1355       --  Local declarations
1356
1357       Scope_Id   : constant Entity_Id   := Find_What_It_Applies_To;
1358       Kind       : constant Entity_Kind := Ekind (Scope_Id);
1359       Loc        : constant Source_Ptr  := Sloc (N);
1360       Stm_Entity : constant Entity_Id   :=
1361                      New_Internal_Entity
1362                        (E_Return_Statement, Current_Scope, Loc, 'R');
1363
1364    --  Start of processing for Analyze_Return_Statement
1365
1366    begin
1367       Set_Return_Statement_Entity (N, Stm_Entity);
1368
1369       Set_Etype (Stm_Entity, Standard_Void_Type);
1370       Set_Return_Applies_To (Stm_Entity, Scope_Id);
1371
1372       --  Place Return entity on scope stack, to simplify enforcement of 6.5
1373       --  (4/2): an inner return statement will apply to this extended return.
1374
1375       if Nkind (N) = N_Extended_Return_Statement then
1376          Push_Scope (Stm_Entity);
1377       end if;
1378
1379       --  Check that pragma No_Return is obeyed. Don't complain about the
1380       --  implicitly-generated return that is placed at the end.
1381
1382       if No_Return (Scope_Id) and then Comes_From_Source (N) then
1383          Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
1384       end if;
1385
1386       --  Warn on any unassigned OUT parameters if in procedure
1387
1388       if Ekind (Scope_Id) = E_Procedure then
1389          Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
1390       end if;
1391
1392       --  Check that functions return objects, and other things do not
1393
1394       if Kind = E_Function or else Kind = E_Generic_Function then
1395          if not Returns_Object then
1396             Error_Msg_N ("missing expression in return from function", N);
1397          end if;
1398
1399       elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
1400          if Returns_Object then
1401             Error_Msg_N ("procedure cannot return value (use function)", N);
1402          end if;
1403
1404       elsif Kind = E_Entry or else Kind = E_Entry_Family then
1405          if Returns_Object then
1406             if Is_Protected_Type (Scope (Scope_Id)) then
1407                Error_Msg_N ("entry body cannot return value", N);
1408             else
1409                Error_Msg_N ("accept statement cannot return value", N);
1410             end if;
1411          end if;
1412
1413       elsif Kind = E_Return_Statement then
1414
1415          --  We are nested within another return statement, which must be an
1416          --  extended_return_statement.
1417
1418          if Returns_Object then
1419             Error_Msg_N
1420               ("extended_return_statement cannot return value; " &
1421                "use `""RETURN;""`", N);
1422          end if;
1423
1424       else
1425          Error_Msg_N ("illegal context for return statement", N);
1426       end if;
1427
1428       if Ekind_In (Kind, E_Function, E_Generic_Function) then
1429          Analyze_Function_Return (N);
1430
1431       elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then
1432          Set_Return_Present (Scope_Id);
1433       end if;
1434
1435       if Nkind (N) = N_Extended_Return_Statement then
1436          End_Scope;
1437       end if;
1438
1439       Kill_Current_Values (Last_Assignment_Only => True);
1440       Check_Unreachable_Code (N);
1441    end Analyze_Return_Statement;
1442
1443    -------------------------------------
1444    -- Analyze_Simple_Return_Statement --
1445    -------------------------------------
1446
1447    procedure Analyze_Simple_Return_Statement (N : Node_Id) is
1448    begin
1449       if Present (Expression (N)) then
1450          Mark_Coextensions (N, Expression (N));
1451       end if;
1452
1453       Analyze_Return_Statement (N);
1454    end Analyze_Simple_Return_Statement;
1455
1456    -------------------------
1457    -- Analyze_Return_Type --
1458    -------------------------
1459
1460    procedure Analyze_Return_Type (N : Node_Id) is
1461       Designator : constant Entity_Id := Defining_Entity (N);
1462       Typ        : Entity_Id := Empty;
1463
1464    begin
1465       --  Normal case where result definition does not indicate an error
1466
1467       if Result_Definition (N) /= Error then
1468          if Nkind (Result_Definition (N)) = N_Access_Definition then
1469             Check_SPARK_Restriction
1470               ("access result is not allowed", Result_Definition (N));
1471
1472             --  Ada 2005 (AI-254): Handle anonymous access to subprograms
1473
1474             declare
1475                AD : constant Node_Id :=
1476                       Access_To_Subprogram_Definition (Result_Definition (N));
1477             begin
1478                if Present (AD) and then Protected_Present (AD) then
1479                   Typ := Replace_Anonymous_Access_To_Protected_Subprogram (N);
1480                else
1481                   Typ := Access_Definition (N, Result_Definition (N));
1482                end if;
1483             end;
1484
1485             Set_Parent (Typ, Result_Definition (N));
1486             Set_Is_Local_Anonymous_Access (Typ);
1487             Set_Etype (Designator, Typ);
1488
1489             --  Ada 2005 (AI-231): Ensure proper usage of null exclusion
1490
1491             Null_Exclusion_Static_Checks (N);
1492
1493          --  Subtype_Mark case
1494
1495          else
1496             Find_Type (Result_Definition (N));
1497             Typ := Entity (Result_Definition (N));
1498             Set_Etype (Designator, Typ);
1499
1500             --  Unconstrained array as result is not allowed in SPARK
1501
1502             if Is_Array_Type (Typ)
1503               and then not Is_Constrained (Typ)
1504             then
1505                Check_SPARK_Restriction
1506                  ("returning an unconstrained array is not allowed",
1507                   Result_Definition (N));
1508             end if;
1509
1510             --  Ada 2005 (AI-231): Ensure proper usage of null exclusion
1511
1512             Null_Exclusion_Static_Checks (N);
1513
1514             --  If a null exclusion is imposed on the result type, then create
1515             --  a null-excluding itype (an access subtype) and use it as the
1516             --  function's Etype. Note that the null exclusion checks are done
1517             --  right before this, because they don't get applied to types that
1518             --  do not come from source.
1519
1520             if Is_Access_Type (Typ)
1521               and then Null_Exclusion_Present (N)
1522             then
1523                Set_Etype  (Designator,
1524                  Create_Null_Excluding_Itype
1525                   (T           => Typ,
1526                    Related_Nod => N,
1527                    Scope_Id    => Scope (Current_Scope)));
1528
1529                --  The new subtype must be elaborated before use because
1530                --  it is visible outside of the function. However its base
1531                --  type may not be frozen yet, so the reference that will
1532                --  force elaboration must be attached to the freezing of
1533                --  the base type.
1534
1535                --  If the return specification appears on a proper body,
1536                --  the subtype will have been created already on the spec.
1537
1538                if Is_Frozen (Typ) then
1539                   if Nkind (Parent (N)) = N_Subprogram_Body
1540                     and then Nkind (Parent (Parent (N))) = N_Subunit
1541                   then
1542                      null;
1543                   else
1544                      Build_Itype_Reference (Etype (Designator), Parent (N));
1545                   end if;
1546
1547                else
1548                   Ensure_Freeze_Node (Typ);
1549
1550                   declare
1551                      IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
1552                   begin
1553                      Set_Itype (IR, Etype (Designator));
1554                      Append_Freeze_Actions (Typ, New_List (IR));
1555                   end;
1556                end if;
1557
1558             else
1559                Set_Etype (Designator, Typ);
1560             end if;
1561
1562             if Ekind (Typ) = E_Incomplete_Type
1563               and then Is_Value_Type (Typ)
1564             then
1565                null;
1566
1567             elsif Ekind (Typ) = E_Incomplete_Type
1568               or else (Is_Class_Wide_Type (Typ)
1569                          and then
1570                            Ekind (Root_Type (Typ)) = E_Incomplete_Type)
1571             then
1572                --  AI05-0151: Tagged incomplete types are allowed in all formal
1573                --  parts. Untagged incomplete types are not allowed in bodies.
1574
1575                if Ada_Version >= Ada_2012 then
1576                   if Is_Tagged_Type (Typ) then
1577                      null;
1578
1579                   elsif Nkind_In (Parent (Parent (N)),
1580                      N_Accept_Statement,
1581                      N_Entry_Body,
1582                      N_Subprogram_Body)
1583                   then
1584                      Error_Msg_NE
1585                        ("invalid use of untagged incomplete type&",
1586                           Designator, Typ);
1587                   end if;
1588
1589                else
1590                   Error_Msg_NE
1591                     ("invalid use of incomplete type&", Designator, Typ);
1592                end if;
1593             end if;
1594          end if;
1595
1596       --  Case where result definition does indicate an error
1597
1598       else
1599          Set_Etype (Designator, Any_Type);
1600       end if;
1601    end Analyze_Return_Type;
1602
1603    -----------------------------
1604    -- Analyze_Subprogram_Body --
1605    -----------------------------
1606
1607    procedure Analyze_Subprogram_Body (N : Node_Id) is
1608       Loc       : constant Source_Ptr := Sloc (N);
1609       Body_Spec : constant Node_Id    := Specification (N);
1610       Body_Id   : constant Entity_Id  := Defining_Entity (Body_Spec);
1611
1612    begin
1613       if Debug_Flag_C then
1614          Write_Str ("==> subprogram body ");
1615          Write_Name (Chars (Body_Id));
1616          Write_Str (" from ");
1617          Write_Location (Loc);
1618          Write_Eol;
1619          Indent;
1620       end if;
1621
1622       Trace_Scope (N, Body_Id, " Analyze subprogram: ");
1623
1624       --  The real work is split out into the helper, so it can do "return;"
1625       --  without skipping the debug output:
1626
1627       Analyze_Subprogram_Body_Helper (N);
1628
1629       if Debug_Flag_C then
1630          Outdent;
1631          Write_Str ("<== subprogram body ");
1632          Write_Name (Chars (Body_Id));
1633          Write_Str (" from ");
1634          Write_Location (Loc);
1635          Write_Eol;
1636       end if;
1637    end Analyze_Subprogram_Body;
1638
1639    ------------------------------------
1640    -- Analyze_Subprogram_Body_Helper --
1641    ------------------------------------
1642
1643    --  This procedure is called for regular subprogram bodies, generic bodies,
1644    --  and for subprogram stubs of both kinds. In the case of stubs, only the
1645    --  specification matters, and is used to create a proper declaration for
1646    --  the subprogram, or to perform conformance checks.
1647
1648    procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
1649       Loc          : constant Source_Ptr := Sloc (N);
1650       Body_Deleted : constant Boolean    := False;
1651       Body_Spec    : constant Node_Id    := Specification (N);
1652       Body_Id      : Entity_Id           := Defining_Entity (Body_Spec);
1653       Prev_Id      : constant Entity_Id  := Current_Entity_In_Scope (Body_Id);
1654       Conformant   : Boolean;
1655       HSS          : Node_Id;
1656       P_Ent        : Entity_Id;
1657       Prot_Typ     : Entity_Id := Empty;
1658       Spec_Id      : Entity_Id;
1659       Spec_Decl    : Node_Id   := Empty;
1660
1661       Last_Real_Spec_Entity : Entity_Id := Empty;
1662       --  When we analyze a separate spec, the entity chain ends up containing
1663       --  the formals, as well as any itypes generated during analysis of the
1664       --  default expressions for parameters, or the arguments of associated
1665       --  precondition/postcondition pragmas (which are analyzed in the context
1666       --  of the spec since they have visibility on formals).
1667       --
1668       --  These entities belong with the spec and not the body. However we do
1669       --  the analysis of the body in the context of the spec (again to obtain
1670       --  visibility to the formals), and all the entities generated during
1671       --  this analysis end up also chained to the entity chain of the spec.
1672       --  But they really belong to the body, and there is circuitry to move
1673       --  them from the spec to the body.
1674       --
1675       --  However, when we do this move, we don't want to move the real spec
1676       --  entities (first para above) to the body. The Last_Real_Spec_Entity
1677       --  variable points to the last real spec entity, so we only move those
1678       --  chained beyond that point. It is initialized to Empty to deal with
1679       --  the case where there is no separate spec.
1680
1681       procedure Check_Anonymous_Return;
1682       --  Ada 2005: if a function returns an access type that denotes a task,
1683       --  or a type that contains tasks, we must create a master entity for
1684       --  the anonymous type, which typically will be used in an allocator
1685       --  in the body of the function.
1686
1687       procedure Check_Inline_Pragma (Spec : in out Node_Id);
1688       --  Look ahead to recognize a pragma that may appear after the body.
1689       --  If there is a previous spec, check that it appears in the same
1690       --  declarative part. If the pragma is Inline_Always, perform inlining
1691       --  unconditionally, otherwise only if Front_End_Inlining is requested.
1692       --  If the body acts as a spec, and inlining is required, we create a
1693       --  subprogram declaration for it, in order to attach the body to inline.
1694       --  If pragma does not appear after the body, check whether there is
1695       --  an inline pragma before any local declarations.
1696
1697       procedure Check_Missing_Return;
1698       --  Checks for a function with a no return statements, and also performs
1699       --  the warning checks implemented by Check_Returns. In formal mode, also
1700       --  verify that a function ends with a RETURN and that a procedure does
1701       --  not contain any RETURN.
1702
1703       function Disambiguate_Spec return Entity_Id;
1704       --  When a primitive is declared between the private view and the full
1705       --  view of a concurrent type which implements an interface, a special
1706       --  mechanism is used to find the corresponding spec of the primitive
1707       --  body.
1708
1709       function Is_Private_Concurrent_Primitive
1710         (Subp_Id : Entity_Id) return Boolean;
1711       --  Determine whether subprogram Subp_Id is a primitive of a concurrent
1712       --  type that implements an interface and has a private view.
1713
1714       procedure Set_Trivial_Subprogram (N : Node_Id);
1715       --  Sets the Is_Trivial_Subprogram flag in both spec and body of the
1716       --  subprogram whose body is being analyzed. N is the statement node
1717       --  causing the flag to be set, if the following statement is a return
1718       --  of an entity, we mark the entity as set in source to suppress any
1719       --  warning on the stylized use of function stubs with a dummy return.
1720
1721       procedure Verify_Overriding_Indicator;
1722       --  If there was a previous spec, the entity has been entered in the
1723       --  current scope previously. If the body itself carries an overriding
1724       --  indicator, check that it is consistent with the known status of the
1725       --  entity.
1726
1727       ----------------------------
1728       -- Check_Anonymous_Return --
1729       ----------------------------
1730
1731       procedure Check_Anonymous_Return is
1732          Decl : Node_Id;
1733          Par  : Node_Id;
1734          Scop : Entity_Id;
1735
1736       begin
1737          if Present (Spec_Id) then
1738             Scop := Spec_Id;
1739          else
1740             Scop := Body_Id;
1741          end if;
1742
1743          if Ekind (Scop) = E_Function
1744            and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type
1745            and then not Is_Thunk (Scop)
1746            and then (Has_Task (Designated_Type (Etype (Scop)))
1747                       or else
1748                        (Is_Class_Wide_Type (Designated_Type (Etype (Scop)))
1749                           and then
1750                         Is_Limited_Record (Designated_Type (Etype (Scop)))))
1751            and then Expander_Active
1752
1753             --  Avoid cases with no tasking support
1754
1755            and then RTE_Available (RE_Current_Master)
1756            and then not Restriction_Active (No_Task_Hierarchy)
1757          then
1758             Decl :=
1759               Make_Object_Declaration (Loc,
1760                 Defining_Identifier =>
1761                   Make_Defining_Identifier (Loc, Name_uMaster),
1762                 Constant_Present => True,
1763                 Object_Definition =>
1764                   New_Reference_To (RTE (RE_Master_Id), Loc),
1765                 Expression =>
1766                   Make_Explicit_Dereference (Loc,
1767                     New_Reference_To (RTE (RE_Current_Master), Loc)));
1768
1769             if Present (Declarations (N)) then
1770                Prepend (Decl, Declarations (N));
1771             else
1772                Set_Declarations (N, New_List (Decl));
1773             end if;
1774
1775             Set_Master_Id (Etype (Scop), Defining_Identifier (Decl));
1776             Set_Has_Master_Entity (Scop);
1777
1778             --  Now mark the containing scope as a task master
1779
1780             Par := N;
1781             while Nkind (Par) /= N_Compilation_Unit loop
1782                Par := Parent (Par);
1783                pragma Assert (Present (Par));
1784
1785                --  If we fall off the top, we are at the outer level, and
1786                --  the environment task is our effective master, so nothing
1787                --  to mark.
1788
1789                if Nkind_In
1790                    (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
1791                then
1792                   Set_Is_Task_Master (Par, True);
1793                   exit;
1794                end if;
1795             end loop;
1796          end if;
1797       end Check_Anonymous_Return;
1798
1799       -------------------------
1800       -- Check_Inline_Pragma --
1801       -------------------------
1802
1803       procedure Check_Inline_Pragma (Spec : in out Node_Id) is
1804          Prag  : Node_Id;
1805          Plist : List_Id;
1806
1807          function Is_Inline_Pragma (N : Node_Id) return Boolean;
1808          --  True when N is a pragma Inline or Inline_Always that applies
1809          --  to this subprogram.
1810
1811          -----------------------
1812          --  Is_Inline_Pragma --
1813          -----------------------
1814
1815          function Is_Inline_Pragma (N : Node_Id) return Boolean is
1816          begin
1817             return
1818               Nkind (N) = N_Pragma
1819                 and then
1820                    (Pragma_Name (N) = Name_Inline_Always
1821                      or else
1822                       (Front_End_Inlining
1823                         and then Pragma_Name (N) = Name_Inline))
1824                 and then
1825                    Chars
1826                      (Expression (First (Pragma_Argument_Associations (N))))
1827                         = Chars (Body_Id);
1828          end Is_Inline_Pragma;
1829
1830       --  Start of processing for Check_Inline_Pragma
1831
1832       begin
1833          if not Expander_Active then
1834             return;
1835          end if;
1836
1837          if Is_List_Member (N)
1838            and then Present (Next (N))
1839            and then Is_Inline_Pragma (Next (N))
1840          then
1841             Prag := Next (N);
1842
1843          elsif Nkind (N) /= N_Subprogram_Body_Stub
1844            and then Present (Declarations (N))
1845            and then Is_Inline_Pragma (First (Declarations (N)))
1846          then
1847             Prag := First (Declarations (N));
1848
1849          else
1850             Prag := Empty;
1851          end if;
1852
1853          if Present (Prag) then
1854             if Present (Spec_Id) then
1855                if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then
1856                   Analyze (Prag);
1857                end if;
1858
1859             else
1860                --  Create a subprogram declaration, to make treatment uniform
1861
1862                declare
1863                   Subp : constant Entity_Id :=
1864                            Make_Defining_Identifier (Loc, Chars (Body_Id));
1865                   Decl : constant Node_Id :=
1866                            Make_Subprogram_Declaration (Loc,
1867                              Specification =>
1868                                New_Copy_Tree (Specification (N)));
1869
1870                begin
1871                   Set_Defining_Unit_Name (Specification (Decl), Subp);
1872
1873                   if Present (First_Formal (Body_Id)) then
1874                      Plist := Copy_Parameter_List (Body_Id);
1875                      Set_Parameter_Specifications
1876                        (Specification (Decl), Plist);
1877                   end if;
1878
1879                   Insert_Before (N, Decl);
1880                   Analyze (Decl);
1881                   Analyze (Prag);
1882                   Set_Has_Pragma_Inline (Subp);
1883
1884                   if Pragma_Name (Prag) = Name_Inline_Always then
1885                      Set_Is_Inlined (Subp);
1886                      Set_Has_Pragma_Inline_Always (Subp);
1887                   end if;
1888
1889                   Spec := Subp;
1890                end;
1891             end if;
1892          end if;
1893       end Check_Inline_Pragma;
1894
1895       --------------------------
1896       -- Check_Missing_Return --
1897       --------------------------
1898
1899       procedure Check_Missing_Return is
1900          Id          : Entity_Id;
1901          Missing_Ret : Boolean;
1902
1903       begin
1904          if Nkind (Body_Spec) = N_Function_Specification then
1905             if Present (Spec_Id) then
1906                Id := Spec_Id;
1907             else
1908                Id := Body_Id;
1909             end if;
1910
1911             if Return_Present (Id) then
1912                Check_Returns (HSS, 'F', Missing_Ret);
1913
1914                if Missing_Ret then
1915                   Set_Has_Missing_Return (Id);
1916                end if;
1917
1918             elsif (Is_Generic_Subprogram (Id)
1919                      or else not Is_Machine_Code_Subprogram (Id))
1920               and then not Body_Deleted
1921             then
1922                Error_Msg_N ("missing RETURN statement in function body", N);
1923             end if;
1924
1925          --  If procedure with No_Return, check returns
1926
1927          elsif Nkind (Body_Spec) = N_Procedure_Specification
1928            and then Present (Spec_Id)
1929            and then No_Return (Spec_Id)
1930          then
1931             Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
1932          end if;
1933
1934          --  Special checks in SPARK mode
1935
1936          if Nkind (Body_Spec) = N_Function_Specification then
1937
1938             --  In SPARK mode, last statement of a function should be a return
1939
1940             declare
1941                Stat : constant Node_Id := Last_Source_Statement (HSS);
1942             begin
1943                if Present (Stat)
1944                  and then not Nkind_In (Stat, N_Simple_Return_Statement,
1945                                               N_Extended_Return_Statement)
1946                then
1947                   Check_SPARK_Restriction
1948                     ("last statement in function should be RETURN", Stat);
1949                end if;
1950             end;
1951
1952          --  In SPARK mode, verify that a procedure has no return
1953
1954          elsif Nkind (Body_Spec) = N_Procedure_Specification then
1955             if Present (Spec_Id) then
1956                Id := Spec_Id;
1957             else
1958                Id := Body_Id;
1959             end if;
1960
1961             --  Would be nice to point to return statement here, can we
1962             --  borrow the Check_Returns procedure here ???
1963
1964             if Return_Present (Id) then
1965                Check_SPARK_Restriction
1966                  ("procedure should not have RETURN", N);
1967             end if;
1968          end if;
1969       end Check_Missing_Return;
1970
1971       -----------------------
1972       -- Disambiguate_Spec --
1973       -----------------------
1974
1975       function Disambiguate_Spec return Entity_Id is
1976          Priv_Spec : Entity_Id;
1977          Spec_N    : Entity_Id;
1978
1979          procedure Replace_Types (To_Corresponding : Boolean);
1980          --  Depending on the flag, replace the type of formal parameters of
1981          --  Body_Id if it is a concurrent type implementing interfaces with
1982          --  the corresponding record type or the other way around.
1983
1984          procedure Replace_Types (To_Corresponding : Boolean) is
1985             Formal     : Entity_Id;
1986             Formal_Typ : Entity_Id;
1987
1988          begin
1989             Formal := First_Formal (Body_Id);
1990             while Present (Formal) loop
1991                Formal_Typ := Etype (Formal);
1992
1993                if Is_Class_Wide_Type (Formal_Typ) then
1994                   Formal_Typ := Root_Type (Formal_Typ);
1995                end if;
1996
1997                --  From concurrent type to corresponding record
1998
1999                if To_Corresponding then
2000                   if Is_Concurrent_Type (Formal_Typ)
2001                     and then Present (Corresponding_Record_Type (Formal_Typ))
2002                     and then Present (Interfaces (
2003                                Corresponding_Record_Type (Formal_Typ)))
2004                   then
2005                      Set_Etype (Formal,
2006                        Corresponding_Record_Type (Formal_Typ));
2007                   end if;
2008
2009                --  From corresponding record to concurrent type
2010
2011                else
2012                   if Is_Concurrent_Record_Type (Formal_Typ)
2013                     and then Present (Interfaces (Formal_Typ))
2014                   then
2015                      Set_Etype (Formal,
2016                        Corresponding_Concurrent_Type (Formal_Typ));
2017                   end if;
2018                end if;
2019
2020                Next_Formal (Formal);
2021             end loop;
2022          end Replace_Types;
2023
2024       --  Start of processing for Disambiguate_Spec
2025
2026       begin
2027          --  Try to retrieve the specification of the body as is. All error
2028          --  messages are suppressed because the body may not have a spec in
2029          --  its current state.
2030
2031          Spec_N := Find_Corresponding_Spec (N, False);
2032
2033          --  It is possible that this is the body of a primitive declared
2034          --  between a private and a full view of a concurrent type. The
2035          --  controlling parameter of the spec carries the concurrent type,
2036          --  not the corresponding record type as transformed by Analyze_
2037          --  Subprogram_Specification. In such cases, we undo the change
2038          --  made by the analysis of the specification and try to find the
2039          --  spec again.
2040
2041          --  Note that wrappers already have their corresponding specs and
2042          --  bodies set during their creation, so if the candidate spec is
2043          --  a wrapper, then we definitely need to swap all types to their
2044          --  original concurrent status.
2045
2046          if No (Spec_N)
2047            or else Is_Primitive_Wrapper (Spec_N)
2048          then
2049             --  Restore all references of corresponding record types to the
2050             --  original concurrent types.
2051
2052             Replace_Types (To_Corresponding => False);
2053             Priv_Spec := Find_Corresponding_Spec (N, False);
2054
2055             --  The current body truly belongs to a primitive declared between
2056             --  a private and a full view. We leave the modified body as is,
2057             --  and return the true spec.
2058
2059             if Present (Priv_Spec)
2060               and then Is_Private_Primitive (Priv_Spec)
2061             then
2062                return Priv_Spec;
2063             end if;
2064
2065             --  In case that this is some sort of error, restore the original
2066             --  state of the body.
2067
2068             Replace_Types (To_Corresponding => True);
2069          end if;
2070
2071          return Spec_N;
2072       end Disambiguate_Spec;
2073
2074       -------------------------------------
2075       -- Is_Private_Concurrent_Primitive --
2076       -------------------------------------
2077
2078       function Is_Private_Concurrent_Primitive
2079         (Subp_Id : Entity_Id) return Boolean
2080       is
2081          Formal_Typ : Entity_Id;
2082
2083       begin
2084          if Present (First_Formal (Subp_Id)) then
2085             Formal_Typ := Etype (First_Formal (Subp_Id));
2086
2087             if Is_Concurrent_Record_Type (Formal_Typ) then
2088                if Is_Class_Wide_Type (Formal_Typ) then
2089                   Formal_Typ := Root_Type (Formal_Typ);
2090                end if;
2091
2092                Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ);
2093             end if;
2094
2095             --  The type of the first formal is a concurrent tagged type with
2096             --  a private view.
2097
2098             return
2099               Is_Concurrent_Type (Formal_Typ)
2100                 and then Is_Tagged_Type (Formal_Typ)
2101                 and then Has_Private_Declaration (Formal_Typ);
2102          end if;
2103
2104          return False;
2105       end Is_Private_Concurrent_Primitive;
2106
2107       ----------------------------
2108       -- Set_Trivial_Subprogram --
2109       ----------------------------
2110
2111       procedure Set_Trivial_Subprogram (N : Node_Id) is
2112          Nxt : constant Node_Id := Next (N);
2113
2114       begin
2115          Set_Is_Trivial_Subprogram (Body_Id);
2116
2117          if Present (Spec_Id) then
2118             Set_Is_Trivial_Subprogram (Spec_Id);
2119          end if;
2120
2121          if Present (Nxt)
2122            and then Nkind (Nxt) = N_Simple_Return_Statement
2123            and then No (Next (Nxt))
2124            and then Present (Expression (Nxt))
2125            and then Is_Entity_Name (Expression (Nxt))
2126          then
2127             Set_Never_Set_In_Source (Entity (Expression (Nxt)), False);
2128          end if;
2129       end Set_Trivial_Subprogram;
2130
2131       ---------------------------------
2132       -- Verify_Overriding_Indicator --
2133       ---------------------------------
2134
2135       procedure Verify_Overriding_Indicator is
2136       begin
2137          if Must_Override (Body_Spec) then
2138             if Nkind (Spec_Id) = N_Defining_Operator_Symbol
2139               and then  Operator_Matches_Spec (Spec_Id, Spec_Id)
2140             then
2141                null;
2142
2143             elsif not Present (Overridden_Operation (Spec_Id)) then
2144                Error_Msg_NE
2145                  ("subprogram& is not overriding", Body_Spec, Spec_Id);
2146             end if;
2147
2148          elsif Must_Not_Override (Body_Spec) then
2149             if Present (Overridden_Operation (Spec_Id)) then
2150                Error_Msg_NE
2151                  ("subprogram& overrides inherited operation",
2152                   Body_Spec, Spec_Id);
2153
2154             elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
2155               and then  Operator_Matches_Spec (Spec_Id, Spec_Id)
2156             then
2157                Error_Msg_NE
2158                  ("subprogram & overrides predefined operator ",
2159                     Body_Spec, Spec_Id);
2160
2161             --  If this is not a primitive operation or protected subprogram,
2162             --  then the overriding indicator is altogether illegal.
2163
2164             elsif not Is_Primitive (Spec_Id)
2165               and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
2166             then
2167                Error_Msg_N
2168                  ("overriding indicator only allowed " &
2169                   "if subprogram is primitive",
2170                   Body_Spec);
2171             end if;
2172
2173          elsif Style_Check
2174            and then Present (Overridden_Operation (Spec_Id))
2175          then
2176             pragma Assert (Unit_Declaration_Node (Body_Id) = N);
2177             Style.Missing_Overriding (N, Body_Id);
2178
2179          elsif Style_Check
2180            and then Can_Override_Operator (Spec_Id)
2181            and then not Is_Predefined_File_Name
2182                           (Unit_File_Name (Get_Source_Unit (Spec_Id)))
2183          then
2184             pragma Assert (Unit_Declaration_Node (Body_Id) = N);
2185             Style.Missing_Overriding (N, Body_Id);
2186          end if;
2187       end Verify_Overriding_Indicator;
2188
2189    --  Start of processing for Analyze_Subprogram_Body_Helper
2190
2191    begin
2192       --  Generic subprograms are handled separately. They always have a
2193       --  generic specification. Determine whether current scope has a
2194       --  previous declaration.
2195
2196       --  If the subprogram body is defined within an instance of the same
2197       --  name, the instance appears as a package renaming, and will be hidden
2198       --  within the subprogram.
2199
2200       if Present (Prev_Id)
2201         and then not Is_Overloadable (Prev_Id)
2202         and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
2203                    or else Comes_From_Source (Prev_Id))
2204       then
2205          if Is_Generic_Subprogram (Prev_Id) then
2206             Spec_Id := Prev_Id;
2207             Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
2208             Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
2209
2210             Analyze_Generic_Subprogram_Body (N, Spec_Id);
2211
2212             if Nkind (N) = N_Subprogram_Body then
2213                HSS := Handled_Statement_Sequence (N);
2214                Check_Missing_Return;
2215             end if;
2216
2217             return;
2218
2219          else
2220             --  Previous entity conflicts with subprogram name. Attempting to
2221             --  enter name will post error.
2222
2223             Enter_Name (Body_Id);
2224             return;
2225          end if;
2226
2227       --  Non-generic case, find the subprogram declaration, if one was seen,
2228       --  or enter new overloaded entity in the current scope. If the
2229       --  Current_Entity is the Body_Id itself, the unit is being analyzed as
2230       --  part of the context of one of its subunits. No need to redo the
2231       --  analysis.
2232
2233       elsif Prev_Id = Body_Id
2234         and then Has_Completion (Body_Id)
2235       then
2236          return;
2237
2238       else
2239          Body_Id := Analyze_Subprogram_Specification (Body_Spec);
2240
2241          if Nkind (N) = N_Subprogram_Body_Stub
2242            or else No (Corresponding_Spec (N))
2243          then
2244             if Is_Private_Concurrent_Primitive (Body_Id) then
2245                Spec_Id := Disambiguate_Spec;
2246             else
2247                Spec_Id := Find_Corresponding_Spec (N);
2248             end if;
2249
2250             --  If this is a duplicate body, no point in analyzing it
2251
2252             if Error_Posted (N) then
2253                return;
2254             end if;
2255
2256             --  A subprogram body should cause freezing of its own declaration,
2257             --  but if there was no previous explicit declaration, then the
2258             --  subprogram will get frozen too late (there may be code within
2259             --  the body that depends on the subprogram having been frozen,
2260             --  such as uses of extra formals), so we force it to be frozen
2261             --  here. Same holds if the body and spec are compilation units.
2262             --  Finally, if the return type is an anonymous access to protected
2263             --  subprogram, it must be frozen before the body because its
2264             --  expansion has generated an equivalent type that is used when
2265             --  elaborating the body.
2266
2267             if No (Spec_Id) then
2268                Freeze_Before (N, Body_Id);
2269
2270             elsif Nkind (Parent (N)) = N_Compilation_Unit then
2271                Freeze_Before (N, Spec_Id);
2272
2273             elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then
2274                Freeze_Before (N, Etype (Body_Id));
2275             end if;
2276
2277          else
2278             Spec_Id := Corresponding_Spec (N);
2279          end if;
2280       end if;
2281
2282       --  Do not inline any subprogram that contains nested subprograms, since
2283       --  the backend inlining circuit seems to generate uninitialized
2284       --  references in this case. We know this happens in the case of front
2285       --  end ZCX support, but it also appears it can happen in other cases as
2286       --  well. The backend often rejects attempts to inline in the case of
2287       --  nested procedures anyway, so little if anything is lost by this.
2288       --  Note that this is test is for the benefit of the back-end. There is
2289       --  a separate test for front-end inlining that also rejects nested
2290       --  subprograms.
2291
2292       --  Do not do this test if errors have been detected, because in some
2293       --  error cases, this code blows up, and we don't need it anyway if
2294       --  there have been errors, since we won't get to the linker anyway.
2295
2296       if Comes_From_Source (Body_Id)
2297         and then Serious_Errors_Detected = 0
2298       then
2299          P_Ent := Body_Id;
2300          loop
2301             P_Ent := Scope (P_Ent);
2302             exit when No (P_Ent) or else P_Ent = Standard_Standard;
2303
2304             if Is_Subprogram (P_Ent) then
2305                Set_Is_Inlined (P_Ent, False);
2306
2307                if Comes_From_Source (P_Ent)
2308                  and then Has_Pragma_Inline (P_Ent)
2309                then
2310                   Cannot_Inline
2311                     ("cannot inline& (nested subprogram)?",
2312                      N, P_Ent);
2313                end if;
2314             end if;
2315          end loop;
2316       end if;
2317
2318       Check_Inline_Pragma (Spec_Id);
2319
2320       --  Deal with special case of a fully private operation in the body of
2321       --  the protected type. We must create a declaration for the subprogram,
2322       --  in order to attach the protected subprogram that will be used in
2323       --  internal calls. We exclude compiler generated bodies from the
2324       --  expander since the issue does not arise for those cases.
2325
2326       if No (Spec_Id)
2327         and then Comes_From_Source (N)
2328         and then Is_Protected_Type (Current_Scope)
2329       then
2330          Spec_Id := Build_Private_Protected_Declaration (N);
2331       end if;
2332
2333       --  If a separate spec is present, then deal with freezing issues
2334
2335       if Present (Spec_Id) then
2336          Spec_Decl := Unit_Declaration_Node (Spec_Id);
2337          Verify_Overriding_Indicator;
2338
2339          --  In general, the spec will be frozen when we start analyzing the
2340          --  body. However, for internally generated operations, such as
2341          --  wrapper functions for inherited operations with controlling
2342          --  results, the spec may not have been frozen by the time we
2343          --  expand the freeze actions that include the bodies. In particular,
2344          --  extra formals for accessibility or for return-in-place may need
2345          --  to be generated. Freeze nodes, if any, are inserted before the
2346          --  current body.
2347
2348          if not Is_Frozen (Spec_Id)
2349            and then Expander_Active
2350          then
2351             --  Force the generation of its freezing node to ensure proper
2352             --  management of access types in the backend.
2353
2354             --  This is definitely needed for some cases, but it is not clear
2355             --  why, to be investigated further???
2356
2357             Set_Has_Delayed_Freeze (Spec_Id);
2358             Freeze_Before (N, Spec_Id);
2359          end if;
2360       end if;
2361
2362       --  Mark presence of postcondition procedure in current scope and mark
2363       --  the procedure itself as needing debug info. The latter is important
2364       --  when analyzing decision coverage (for example, for MC/DC coverage).
2365
2366       if Chars (Body_Id) = Name_uPostconditions then
2367          Set_Has_Postconditions (Current_Scope);
2368          Set_Debug_Info_Needed (Body_Id);
2369       end if;
2370
2371       --  Place subprogram on scope stack, and make formals visible. If there
2372       --  is a spec, the visible entity remains that of the spec.
2373
2374       if Present (Spec_Id) then
2375          Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
2376
2377          if Is_Child_Unit (Spec_Id) then
2378             Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
2379          end if;
2380
2381          if Style_Check then
2382             Style.Check_Identifier (Body_Id, Spec_Id);
2383          end if;
2384
2385          Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
2386          Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
2387
2388          if Is_Abstract_Subprogram (Spec_Id) then
2389             Error_Msg_N ("an abstract subprogram cannot have a body", N);
2390             return;
2391
2392          else
2393             Set_Convention (Body_Id, Convention (Spec_Id));
2394             Set_Has_Completion (Spec_Id);
2395
2396             if Is_Protected_Type (Scope (Spec_Id)) then
2397                Prot_Typ := Scope (Spec_Id);
2398             end if;
2399
2400             --  If this is a body generated for a renaming, do not check for
2401             --  full conformance. The check is redundant, because the spec of
2402             --  the body is a copy of the spec in the renaming declaration,
2403             --  and the test can lead to spurious errors on nested defaults.
2404
2405             if Present (Spec_Decl)
2406               and then not Comes_From_Source (N)
2407               and then
2408                 (Nkind (Original_Node (Spec_Decl)) =
2409                                         N_Subprogram_Renaming_Declaration
2410                    or else (Present (Corresponding_Body (Spec_Decl))
2411                               and then
2412                                 Nkind (Unit_Declaration_Node
2413                                         (Corresponding_Body (Spec_Decl))) =
2414                                            N_Subprogram_Renaming_Declaration))
2415             then
2416                Conformant := True;
2417
2418             --  Conversely, the spec may have been generated for specless body
2419             --  with an inline pragma.
2420
2421             elsif Comes_From_Source (N)
2422               and then not Comes_From_Source (Spec_Id)
2423               and then Has_Pragma_Inline (Spec_Id)
2424             then
2425                Conformant := True;
2426
2427             else
2428                Check_Conformance
2429                  (Body_Id, Spec_Id,
2430                   Fully_Conformant, True, Conformant, Body_Id);
2431             end if;
2432
2433             --  If the body is not fully conformant, we have to decide if we
2434             --  should analyze it or not. If it has a really messed up profile
2435             --  then we probably should not analyze it, since we will get too
2436             --  many bogus messages.
2437
2438             --  Our decision is to go ahead in the non-fully conformant case
2439             --  only if it is at least mode conformant with the spec. Note
2440             --  that the call to Check_Fully_Conformant has issued the proper
2441             --  error messages to complain about the lack of conformance.
2442
2443             if not Conformant
2444               and then not Mode_Conformant (Body_Id, Spec_Id)
2445             then
2446                return;
2447             end if;
2448          end if;
2449
2450          if Spec_Id /= Body_Id then
2451             Reference_Body_Formals (Spec_Id, Body_Id);
2452          end if;
2453
2454          if Nkind (N) /= N_Subprogram_Body_Stub then
2455             Set_Corresponding_Spec (N, Spec_Id);
2456
2457             --  Ada 2005 (AI-345): If the operation is a primitive operation
2458             --  of a concurrent type, the type of the first parameter has been
2459             --  replaced with the corresponding record, which is the proper
2460             --  run-time structure to use. However, within the body there may
2461             --  be uses of the formals that depend on primitive operations
2462             --  of the type (in particular calls in prefixed form) for which
2463             --  we need the original concurrent type. The operation may have
2464             --  several controlling formals, so the replacement must be done
2465             --  for all of them.
2466
2467             if Comes_From_Source (Spec_Id)
2468               and then Present (First_Entity (Spec_Id))
2469               and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
2470               and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
2471               and then
2472                 Present (Interfaces (Etype (First_Entity (Spec_Id))))
2473               and then
2474                 Present
2475                   (Corresponding_Concurrent_Type
2476                      (Etype (First_Entity (Spec_Id))))
2477             then
2478                declare
2479                   Typ  : constant Entity_Id := Etype (First_Entity (Spec_Id));
2480                   Form : Entity_Id;
2481
2482                begin
2483                   Form := First_Formal (Spec_Id);
2484                   while Present (Form) loop
2485                      if Etype (Form) = Typ then
2486                         Set_Etype (Form, Corresponding_Concurrent_Type (Typ));
2487                      end if;
2488
2489                      Next_Formal (Form);
2490                   end loop;
2491                end;
2492             end if;
2493
2494             --  Make the formals visible, and place subprogram on scope stack.
2495             --  This is also the point at which we set Last_Real_Spec_Entity
2496             --  to mark the entities which will not be moved to the body.
2497
2498             Install_Formals (Spec_Id);
2499             Last_Real_Spec_Entity := Last_Entity (Spec_Id);
2500             Push_Scope (Spec_Id);
2501
2502             --  Make sure that the subprogram is immediately visible. For
2503             --  child units that have no separate spec this is indispensable.
2504             --  Otherwise it is safe albeit redundant.
2505
2506             Set_Is_Immediately_Visible (Spec_Id);
2507          end if;
2508
2509          Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
2510          Set_Ekind (Body_Id, E_Subprogram_Body);
2511          Set_Scope (Body_Id, Scope (Spec_Id));
2512          Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
2513
2514       --  Case of subprogram body with no previous spec
2515
2516       else
2517          --  Check for style warning required
2518
2519          if Style_Check
2520
2521            --  Only apply check for source level subprograms for which checks
2522            --  have not been suppressed.
2523
2524            and then Comes_From_Source (Body_Id)
2525            and then not Suppress_Style_Checks (Body_Id)
2526
2527            --  No warnings within an instance
2528
2529            and then not In_Instance
2530
2531            --  No warnings for expression functions
2532
2533            and then Nkind (Original_Node (N)) /= N_Expression_Function
2534          then
2535             Style.Body_With_No_Spec (N);
2536          end if;
2537
2538          New_Overloaded_Entity (Body_Id);
2539
2540          if Nkind (N) /= N_Subprogram_Body_Stub then
2541             Set_Acts_As_Spec (N);
2542             Generate_Definition (Body_Id);
2543             Set_Contract (Body_Id, Make_Contract (Sloc (Body_Id)));
2544             Generate_Reference
2545               (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
2546             Generate_Reference_To_Formals (Body_Id);
2547             Install_Formals (Body_Id);
2548             Push_Scope (Body_Id);
2549          end if;
2550       end if;
2551
2552       --  If the return type is an anonymous access type whose designated type
2553       --  is the limited view of a class-wide type and the non-limited view is
2554       --  available, update the return type accordingly.
2555
2556       if Ada_Version >= Ada_2005
2557         and then Comes_From_Source (N)
2558       then
2559          declare
2560             Etyp : Entity_Id;
2561             Rtyp : Entity_Id;
2562
2563          begin
2564             Rtyp := Etype (Current_Scope);
2565
2566             if Ekind (Rtyp) = E_Anonymous_Access_Type then
2567                Etyp := Directly_Designated_Type (Rtyp);
2568
2569                if Is_Class_Wide_Type (Etyp)
2570                  and then From_With_Type (Etyp)
2571                then
2572                   Set_Directly_Designated_Type
2573                     (Etype (Current_Scope), Available_View (Etyp));
2574                end if;
2575             end if;
2576          end;
2577       end if;
2578
2579       --  If this is the proper body of a stub, we must verify that the stub
2580       --  conforms to the body, and to the previous spec if one was present.
2581       --  we know already that the body conforms to that spec. This test is
2582       --  only required for subprograms that come from source.
2583
2584       if Nkind (Parent (N)) = N_Subunit
2585         and then Comes_From_Source (N)
2586         and then not Error_Posted (Body_Id)
2587         and then Nkind (Corresponding_Stub (Parent (N))) =
2588                                                 N_Subprogram_Body_Stub
2589       then
2590          declare
2591             Old_Id : constant Entity_Id :=
2592                        Defining_Entity
2593                          (Specification (Corresponding_Stub (Parent (N))));
2594
2595             Conformant : Boolean := False;
2596
2597          begin
2598             if No (Spec_Id) then
2599                Check_Fully_Conformant (Body_Id, Old_Id);
2600
2601             else
2602                Check_Conformance
2603                  (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
2604
2605                if not Conformant then
2606
2607                   --  The stub was taken to be a new declaration. Indicate
2608                   --  that it lacks a body.
2609
2610                   Set_Has_Completion (Old_Id, False);
2611                end if;
2612             end if;
2613          end;
2614       end if;
2615
2616       Set_Has_Completion (Body_Id);
2617       Check_Eliminated (Body_Id);
2618
2619       if Nkind (N) = N_Subprogram_Body_Stub then
2620          return;
2621
2622       elsif Present (Spec_Id)
2623         and then Expander_Active
2624         and then
2625           (Has_Pragma_Inline_Always (Spec_Id)
2626              or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
2627       then
2628          Build_Body_To_Inline (N, Spec_Id);
2629       end if;
2630
2631       --  Ada 2005 (AI-262): In library subprogram bodies, after the analysis
2632       --  if its specification we have to install the private withed units.
2633       --  This holds for child units as well.
2634
2635       if Is_Compilation_Unit (Body_Id)
2636         or else Nkind (Parent (N)) = N_Compilation_Unit
2637       then
2638          Install_Private_With_Clauses (Body_Id);
2639       end if;
2640
2641       Check_Anonymous_Return;
2642
2643       --  Set the Protected_Formal field of each extra formal of the protected
2644       --  subprogram to reference the corresponding extra formal of the
2645       --  subprogram that implements it. For regular formals this occurs when
2646       --  the protected subprogram's declaration is expanded, but the extra
2647       --  formals don't get created until the subprogram is frozen. We need to
2648       --  do this before analyzing the protected subprogram's body so that any
2649       --  references to the original subprogram's extra formals will be changed
2650       --  refer to the implementing subprogram's formals (see Expand_Formal).
2651
2652       if Present (Spec_Id)
2653         and then Is_Protected_Type (Scope (Spec_Id))
2654         and then Present (Protected_Body_Subprogram (Spec_Id))
2655       then
2656          declare
2657             Impl_Subp       : constant Entity_Id :=
2658                                 Protected_Body_Subprogram (Spec_Id);
2659             Prot_Ext_Formal : Entity_Id := Extra_Formals (Spec_Id);
2660             Impl_Ext_Formal : Entity_Id := Extra_Formals (Impl_Subp);
2661          begin
2662             while Present (Prot_Ext_Formal) loop
2663                pragma Assert (Present (Impl_Ext_Formal));
2664                Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
2665                Next_Formal_With_Extras (Prot_Ext_Formal);
2666                Next_Formal_With_Extras (Impl_Ext_Formal);
2667             end loop;
2668          end;
2669       end if;
2670
2671       --  Now we can go on to analyze the body
2672
2673       HSS := Handled_Statement_Sequence (N);
2674       Set_Actual_Subtypes (N, Current_Scope);
2675
2676       --  Deal with preconditions and postconditions. In formal verification
2677       --  mode, we keep pre- and postconditions attached to entities rather
2678       --  than inserted in the code, in order to facilitate a distinct
2679       --  treatment for them.
2680
2681       if not ALFA_Mode then
2682          Process_PPCs (N, Spec_Id, Body_Id);
2683       end if;
2684
2685       --  Add a declaration for the Protection object, renaming declarations
2686       --  for discriminals and privals and finally a declaration for the entry
2687       --  family index (if applicable). This form of early expansion is done
2688       --  when the Expander is active because Install_Private_Data_Declarations
2689       --  references entities which were created during regular expansion.
2690
2691       if Expander_Active
2692         and then Comes_From_Source (N)
2693         and then Present (Prot_Typ)
2694         and then Present (Spec_Id)
2695         and then not Is_Eliminated (Spec_Id)
2696       then
2697          Install_Private_Data_Declarations
2698            (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N));
2699       end if;
2700
2701       --  Analyze the declarations (this call will analyze the precondition
2702       --  Check pragmas we prepended to the list, as well as the declaration
2703       --  of the _Postconditions procedure).
2704
2705       Analyze_Declarations (Declarations (N));
2706
2707       --  Check completion, and analyze the statements
2708
2709       Check_Completion;
2710       Inspect_Deferred_Constant_Completion (Declarations (N));
2711       Analyze (HSS);
2712
2713       --  Deal with end of scope processing for the body
2714
2715       Process_End_Label (HSS, 't', Current_Scope);
2716       End_Scope;
2717       Check_Subprogram_Order (N);
2718       Set_Analyzed (Body_Id);
2719
2720       --  If we have a separate spec, then the analysis of the declarations
2721       --  caused the entities in the body to be chained to the spec id, but
2722       --  we want them chained to the body id. Only the formal parameters
2723       --  end up chained to the spec id in this case.
2724
2725       if Present (Spec_Id) then
2726
2727          --  We must conform to the categorization of our spec
2728
2729          Validate_Categorization_Dependency (N, Spec_Id);
2730
2731          --  And if this is a child unit, the parent units must conform
2732
2733          if Is_Child_Unit (Spec_Id) then
2734             Validate_Categorization_Dependency
2735               (Unit_Declaration_Node (Spec_Id), Spec_Id);
2736          end if;
2737
2738          --  Here is where we move entities from the spec to the body
2739
2740          --  Case where there are entities that stay with the spec
2741
2742          if Present (Last_Real_Spec_Entity) then
2743
2744             --  No body entities (happens when the only real spec entities
2745             --  come from precondition and postcondition pragmas)
2746
2747             if No (Last_Entity (Body_Id)) then
2748                Set_First_Entity
2749                  (Body_Id, Next_Entity (Last_Real_Spec_Entity));
2750
2751             --  Body entities present (formals), so chain stuff past them
2752
2753             else
2754                Set_Next_Entity
2755                  (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
2756             end if;
2757
2758             Set_Next_Entity (Last_Real_Spec_Entity, Empty);
2759             Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
2760             Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity);
2761
2762          --  Case where there are no spec entities, in this case there can
2763          --  be no body entities either, so just move everything.
2764
2765          else
2766             pragma Assert (No (Last_Entity (Body_Id)));
2767             Set_First_Entity (Body_Id, First_Entity (Spec_Id));
2768             Set_Last_Entity  (Body_Id, Last_Entity (Spec_Id));
2769             Set_First_Entity (Spec_Id, Empty);
2770             Set_Last_Entity  (Spec_Id, Empty);
2771          end if;
2772       end if;
2773
2774       Check_Missing_Return;
2775
2776       --  Now we are going to check for variables that are never modified in
2777       --  the body of the procedure. But first we deal with a special case
2778       --  where we want to modify this check. If the body of the subprogram
2779       --  starts with a raise statement or its equivalent, or if the body
2780       --  consists entirely of a null statement, then it is pretty obvious
2781       --  that it is OK to not reference the parameters. For example, this
2782       --  might be the following common idiom for a stubbed function:
2783       --  statement of the procedure raises an exception. In particular this
2784       --  deals with the common idiom of a stubbed function, which might
2785       --  appear as something like
2786
2787       --     function F (A : Integer) return Some_Type;
2788       --        X : Some_Type;
2789       --     begin
2790       --        raise Program_Error;
2791       --        return X;
2792       --     end F;
2793
2794       --  Here the purpose of X is simply to satisfy the annoying requirement
2795       --  in Ada that there be at least one return, and we certainly do not
2796       --  want to go posting warnings on X that it is not initialized! On
2797       --  the other hand, if X is entirely unreferenced that should still
2798       --  get a warning.
2799
2800       --  What we do is to detect these cases, and if we find them, flag the
2801       --  subprogram as being Is_Trivial_Subprogram and then use that flag to
2802       --  suppress unwanted warnings. For the case of the function stub above
2803       --  we have a special test to set X as apparently assigned to suppress
2804       --  the warning.
2805
2806       declare
2807          Stm : Node_Id;
2808
2809       begin
2810          --  Skip initial labels (for one thing this occurs when we are in
2811          --  front end ZCX mode, but in any case it is irrelevant), and also
2812          --  initial Push_xxx_Error_Label nodes, which are also irrelevant.
2813
2814          Stm := First (Statements (HSS));
2815          while Nkind (Stm) = N_Label
2816            or else Nkind (Stm) in N_Push_xxx_Label
2817          loop
2818             Next (Stm);
2819          end loop;
2820
2821          --  Do the test on the original statement before expansion
2822
2823          declare
2824             Ostm : constant Node_Id := Original_Node (Stm);
2825
2826          begin
2827             --  If explicit raise statement, turn on flag
2828
2829             if Nkind (Ostm) = N_Raise_Statement then
2830                Set_Trivial_Subprogram (Stm);
2831
2832             --  If null statement, and no following statements, turn on flag
2833
2834             elsif Nkind (Stm) = N_Null_Statement
2835               and then Comes_From_Source (Stm)
2836               and then No (Next (Stm))
2837             then
2838                Set_Trivial_Subprogram (Stm);
2839
2840             --  Check for explicit call cases which likely raise an exception
2841
2842             elsif Nkind (Ostm) = N_Procedure_Call_Statement then
2843                if Is_Entity_Name (Name (Ostm)) then
2844                   declare
2845                      Ent : constant Entity_Id := Entity (Name (Ostm));
2846
2847                   begin
2848                      --  If the procedure is marked No_Return, then likely it
2849                      --  raises an exception, but in any case it is not coming
2850                      --  back here, so turn on the flag.
2851
2852                      if Present (Ent)
2853                        and then Ekind (Ent) = E_Procedure
2854                        and then No_Return (Ent)
2855                      then
2856                         Set_Trivial_Subprogram (Stm);
2857                      end if;
2858                   end;
2859                end if;
2860             end if;
2861          end;
2862       end;
2863
2864       --  Check for variables that are never modified
2865
2866       declare
2867          E1, E2 : Entity_Id;
2868
2869       begin
2870          --  If there is a separate spec, then transfer Never_Set_In_Source
2871          --  flags from out parameters to the corresponding entities in the
2872          --  body. The reason we do that is we want to post error flags on
2873          --  the body entities, not the spec entities.
2874
2875          if Present (Spec_Id) then
2876             E1 := First_Entity (Spec_Id);
2877             while Present (E1) loop
2878                if Ekind (E1) = E_Out_Parameter then
2879                   E2 := First_Entity (Body_Id);
2880                   while Present (E2) loop
2881                      exit when Chars (E1) = Chars (E2);
2882                      Next_Entity (E2);
2883                   end loop;
2884
2885                   if Present (E2) then
2886                      Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
2887                   end if;
2888                end if;
2889
2890                Next_Entity (E1);
2891             end loop;
2892          end if;
2893
2894          --  Check references in body unless it was deleted. Note that the
2895          --  check of Body_Deleted here is not just for efficiency, it is
2896          --  necessary to avoid junk warnings on formal parameters.
2897
2898          if not Body_Deleted then
2899             Check_References (Body_Id);
2900          end if;
2901       end;
2902    end Analyze_Subprogram_Body_Helper;
2903
2904    ------------------------------------
2905    -- Analyze_Subprogram_Declaration --
2906    ------------------------------------
2907
2908    procedure Analyze_Subprogram_Declaration (N : Node_Id) is
2909       Loc        : constant Source_Ptr := Sloc (N);
2910       Scop       : constant Entity_Id  := Current_Scope;
2911       Designator : Entity_Id;
2912       Form       : Node_Id;
2913       Null_Body  : Node_Id := Empty;
2914
2915    --  Start of processing for Analyze_Subprogram_Declaration
2916
2917    begin
2918       --  Null procedures are not allowed in SPARK
2919
2920       if Nkind (Specification (N)) = N_Procedure_Specification
2921         and then Null_Present (Specification (N))
2922       then
2923          Check_SPARK_Restriction ("null procedure is not allowed", N);
2924       end if;
2925
2926       --  For a null procedure, capture the profile before analysis, for
2927       --  expansion at the freeze point and at each point of call. The body
2928       --  will only be used if the procedure has preconditions. In that case
2929       --  the body is analyzed at the freeze point.
2930
2931       if Nkind (Specification (N)) = N_Procedure_Specification
2932         and then Null_Present (Specification (N))
2933         and then Expander_Active
2934       then
2935          Null_Body :=
2936            Make_Subprogram_Body (Loc,
2937              Specification =>
2938                New_Copy_Tree (Specification (N)),
2939              Declarations =>
2940                New_List,
2941              Handled_Statement_Sequence =>
2942                Make_Handled_Sequence_Of_Statements (Loc,
2943                  Statements => New_List (Make_Null_Statement (Loc))));
2944
2945          --  Create new entities for body and formals
2946
2947          Set_Defining_Unit_Name (Specification (Null_Body),
2948            Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));
2949          Set_Corresponding_Body (N, Defining_Entity (Null_Body));
2950
2951          Form := First (Parameter_Specifications (Specification (Null_Body)));
2952          while Present (Form) loop
2953             Set_Defining_Identifier (Form,
2954               Make_Defining_Identifier (Loc,
2955                 Chars (Defining_Identifier (Form))));
2956
2957             --  Resolve the types of the formals now, because the freeze point
2958             --  may appear in a different context, e.g. an instantiation.
2959
2960             if Nkind (Parameter_Type (Form)) /= N_Access_Definition then
2961                Find_Type (Parameter_Type (Form));
2962
2963             elsif
2964               No (Access_To_Subprogram_Definition (Parameter_Type (Form)))
2965             then
2966                Find_Type (Subtype_Mark (Parameter_Type (Form)));
2967
2968             else
2969
2970                --  the case of a null procedure with a formal that is an
2971                --  access_to_subprogram type, and that is used as an actual
2972                --  in an instantiation is left to the enthusiastic reader.
2973
2974                null;
2975             end if;
2976
2977             Next (Form);
2978          end loop;
2979
2980          if Is_Protected_Type (Current_Scope) then
2981             Error_Msg_N ("protected operation cannot be a null procedure", N);
2982          end if;
2983       end if;
2984
2985       Designator := Analyze_Subprogram_Specification (Specification (N));
2986       Generate_Definition (Designator);
2987       --  ??? why this call, already in Analyze_Subprogram_Specification
2988
2989       if Debug_Flag_C then
2990          Write_Str ("==> subprogram spec ");
2991          Write_Name (Chars (Designator));
2992          Write_Str (" from ");
2993          Write_Location (Sloc (N));
2994          Write_Eol;
2995          Indent;
2996       end if;
2997
2998       if Nkind (Specification (N)) = N_Procedure_Specification
2999         and then Null_Present (Specification (N))
3000       then
3001          Set_Has_Completion (Designator);
3002
3003          if Present (Null_Body) then
3004             Set_Corresponding_Body (N, Defining_Entity (Null_Body));
3005             Set_Body_To_Inline (N, Null_Body);
3006             Set_Is_Inlined (Designator);
3007          end if;
3008       end if;
3009
3010       Validate_RCI_Subprogram_Declaration (N);
3011       New_Overloaded_Entity (Designator);
3012       Check_Delayed_Subprogram (Designator);
3013
3014       --  If the type of the first formal of the current subprogram is a
3015       --  nongeneric tagged private type, mark the subprogram as being a
3016       --  private primitive. Ditto if this is a function with controlling
3017       --  result, and the return type is currently private. In both cases,
3018       --  the type of the controlling argument or result must be in the
3019       --  current scope for the operation to be primitive.
3020
3021       if Has_Controlling_Result (Designator)
3022         and then Is_Private_Type (Etype (Designator))
3023         and then Scope (Etype (Designator)) = Current_Scope
3024         and then not Is_Generic_Actual_Type (Etype (Designator))
3025       then
3026          Set_Is_Private_Primitive (Designator);
3027
3028       elsif Present (First_Formal (Designator)) then
3029          declare
3030             Formal_Typ : constant Entity_Id :=
3031                            Etype (First_Formal (Designator));
3032          begin
3033             Set_Is_Private_Primitive (Designator,
3034               Is_Tagged_Type (Formal_Typ)
3035                 and then Scope (Formal_Typ) = Current_Scope
3036                 and then Is_Private_Type (Formal_Typ)
3037                 and then not Is_Generic_Actual_Type (Formal_Typ));
3038          end;
3039       end if;
3040
3041       --  Ada 2005 (AI-251): Abstract interface primitives must be abstract
3042       --  or null.
3043
3044       if Ada_Version >= Ada_2005
3045         and then Comes_From_Source (N)
3046         and then Is_Dispatching_Operation (Designator)
3047       then
3048          declare
3049             E    : Entity_Id;
3050             Etyp : Entity_Id;
3051
3052          begin
3053             if Has_Controlling_Result (Designator) then
3054                Etyp := Etype (Designator);
3055
3056             else
3057                E := First_Entity (Designator);
3058                while Present (E)
3059                  and then Is_Formal (E)
3060                  and then not Is_Controlling_Formal (E)
3061                loop
3062                   Next_Entity (E);
3063                end loop;
3064
3065                Etyp := Etype (E);
3066             end if;
3067
3068             if Is_Access_Type (Etyp) then
3069                Etyp := Directly_Designated_Type (Etyp);
3070             end if;
3071
3072             if Is_Interface (Etyp)
3073               and then not Is_Abstract_Subprogram (Designator)
3074               and then not (Ekind (Designator) = E_Procedure
3075                               and then Null_Present (Specification (N)))
3076             then
3077                Error_Msg_Name_1 := Chars (Defining_Entity (N));
3078                Error_Msg_N
3079                  ("(Ada 2005) interface subprogram % must be abstract or null",
3080                   N);
3081             end if;
3082          end;
3083       end if;
3084
3085       --  What is the following code for, it used to be
3086
3087       --  ???   Set_Suppress_Elaboration_Checks
3088       --  ???     (Designator, Elaboration_Checks_Suppressed (Designator));
3089
3090       --  The following seems equivalent, but a bit dubious
3091
3092       if Elaboration_Checks_Suppressed (Designator) then
3093          Set_Kill_Elaboration_Checks (Designator);
3094       end if;
3095
3096       if Scop /= Standard_Standard
3097         and then not Is_Child_Unit (Designator)
3098       then
3099          Set_Categorization_From_Scope (Designator, Scop);
3100       else
3101          --  For a compilation unit, check for library-unit pragmas
3102
3103          Push_Scope (Designator);
3104          Set_Categorization_From_Pragmas (N);
3105          Validate_Categorization_Dependency (N, Designator);
3106          Pop_Scope;
3107       end if;
3108
3109       --  For a compilation unit, set body required. This flag will only be
3110       --  reset if a valid Import or Interface pragma is processed later on.
3111
3112       if Nkind (Parent (N)) = N_Compilation_Unit then
3113          Set_Body_Required (Parent (N), True);
3114
3115          if Ada_Version >= Ada_2005
3116            and then Nkind (Specification (N)) = N_Procedure_Specification
3117            and then Null_Present (Specification (N))
3118          then
3119             Error_Msg_N
3120               ("null procedure cannot be declared at library level", N);
3121          end if;
3122       end if;
3123
3124       Generate_Reference_To_Formals (Designator);
3125       Check_Eliminated (Designator);
3126
3127       if Debug_Flag_C then
3128          Outdent;
3129          Write_Str ("<== subprogram spec ");
3130          Write_Name (Chars (Designator));
3131          Write_Str (" from ");
3132          Write_Location (Sloc (N));
3133          Write_Eol;
3134       end if;
3135
3136       if Is_Protected_Type (Current_Scope) then
3137
3138          --  Indicate that this is a protected operation, because it may be
3139          --  used in subsequent declarations within the protected type.
3140
3141          Set_Convention (Designator, Convention_Protected);
3142       end if;
3143
3144       List_Inherited_Pre_Post_Aspects (Designator);
3145
3146       if Has_Aspects (N) then
3147          Analyze_Aspect_Specifications (N, Designator);
3148       end if;
3149    end Analyze_Subprogram_Declaration;
3150
3151    --------------------------------------
3152    -- Analyze_Subprogram_Specification --
3153    --------------------------------------
3154
3155    --  Reminder: N here really is a subprogram specification (not a subprogram
3156    --  declaration). This procedure is called to analyze the specification in
3157    --  both subprogram bodies and subprogram declarations (specs).
3158
3159    function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
3160       Designator : constant Entity_Id := Defining_Entity (N);
3161       Formals    : constant List_Id   := Parameter_Specifications (N);
3162
3163    --  Start of processing for Analyze_Subprogram_Specification
3164
3165    begin
3166       --  User-defined operator is not allowed in SPARK, except as a renaming
3167
3168       if Nkind (Defining_Unit_Name (N)) = N_Defining_Operator_Symbol
3169         and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
3170       then
3171          Check_SPARK_Restriction ("user-defined operator is not allowed", N);
3172       end if;
3173
3174       --  Proceed with analysis
3175
3176       Generate_Definition (Designator);
3177       Set_Contract (Designator, Make_Contract (Sloc (Designator)));
3178
3179       if Nkind (N) = N_Function_Specification then
3180          Set_Ekind (Designator, E_Function);
3181          Set_Mechanism (Designator, Default_Mechanism);
3182       else
3183          Set_Ekind (Designator, E_Procedure);
3184          Set_Etype (Designator, Standard_Void_Type);
3185       end if;
3186
3187       --  Introduce new scope for analysis of the formals and the return type
3188
3189       Set_Scope (Designator, Current_Scope);
3190
3191       if Present (Formals) then
3192          Push_Scope (Designator);
3193          Process_Formals (Formals, N);
3194
3195          --  Ada 2005 (AI-345): If this is an overriding operation of an
3196          --  inherited interface operation, and the controlling type is
3197          --  a synchronized type, replace the type with its corresponding
3198          --  record, to match the proper signature of an overriding operation.
3199          --  Same processing for an access parameter whose designated type is
3200          --  derived from a synchronized interface.
3201
3202          if Ada_Version >= Ada_2005 then
3203             declare
3204                Formal     : Entity_Id;
3205                Formal_Typ : Entity_Id;
3206                Rec_Typ    : Entity_Id;
3207                Desig_Typ  : Entity_Id;
3208
3209             begin
3210                Formal := First_Formal (Designator);
3211                while Present (Formal) loop
3212                   Formal_Typ := Etype (Formal);
3213
3214                   if Is_Concurrent_Type (Formal_Typ)
3215                     and then Present (Corresponding_Record_Type (Formal_Typ))
3216                   then
3217                      Rec_Typ := Corresponding_Record_Type (Formal_Typ);
3218
3219                      if Present (Interfaces (Rec_Typ)) then
3220                         Set_Etype (Formal, Rec_Typ);
3221                      end if;
3222
3223                   elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then
3224                      Desig_Typ := Designated_Type (Formal_Typ);
3225
3226                      if Is_Concurrent_Type (Desig_Typ)
3227                        and then Present (Corresponding_Record_Type (Desig_Typ))
3228                      then
3229                         Rec_Typ := Corresponding_Record_Type (Desig_Typ);
3230
3231                         if Present (Interfaces (Rec_Typ)) then
3232                            Set_Directly_Designated_Type (Formal_Typ, Rec_Typ);
3233                         end if;
3234                      end if;
3235                   end if;
3236
3237                   Next_Formal (Formal);
3238                end loop;
3239             end;
3240          end if;
3241
3242          End_Scope;
3243
3244       --  The subprogram scope is pushed and popped around the processing of
3245       --  the return type for consistency with call above to Process_Formals
3246       --  (which itself can call Analyze_Return_Type), and to ensure that any
3247       --  itype created for the return type will be associated with the proper
3248       --  scope.
3249
3250       elsif Nkind (N) = N_Function_Specification then
3251          Push_Scope (Designator);
3252          Analyze_Return_Type (N);
3253          End_Scope;
3254       end if;
3255
3256       --  Function case
3257
3258       if Nkind (N) = N_Function_Specification then
3259
3260          --  Deal with operator symbol case
3261
3262          if Nkind (Designator) = N_Defining_Operator_Symbol then
3263             Valid_Operator_Definition (Designator);
3264          end if;
3265
3266          May_Need_Actuals (Designator);
3267
3268          --  Ada 2005 (AI-251): If the return type is abstract, verify that
3269          --  the subprogram is abstract also. This does not apply to renaming
3270          --  declarations, where abstractness is inherited.
3271
3272          --  In case of primitives associated with abstract interface types
3273          --  the check is applied later (see Analyze_Subprogram_Declaration).
3274
3275          if not Nkind_In (Parent (N), N_Subprogram_Renaming_Declaration,
3276                                       N_Abstract_Subprogram_Declaration,
3277                                       N_Formal_Abstract_Subprogram_Declaration)
3278          then
3279             if Is_Abstract_Type (Etype (Designator))
3280               and then not Is_Interface (Etype (Designator))
3281             then
3282                Error_Msg_N
3283                  ("function that returns abstract type must be abstract", N);
3284
3285             --  Ada 2012 (AI-0073): Extend this test to subprograms with an
3286             --  access result whose designated type is abstract.
3287
3288             elsif Nkind (Result_Definition (N)) = N_Access_Definition
3289               and then
3290                 not Is_Class_Wide_Type (Designated_Type (Etype (Designator)))
3291               and then Is_Abstract_Type (Designated_Type (Etype (Designator)))
3292               and then Ada_Version >= Ada_2012
3293             then
3294                Error_Msg_N ("function whose access result designates "
3295                  & "abstract type must be abstract", N);
3296             end if;
3297          end if;
3298       end if;
3299
3300       return Designator;
3301    end Analyze_Subprogram_Specification;
3302
3303    --------------------------
3304    -- Build_Body_To_Inline --
3305    --------------------------
3306
3307    procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
3308       Decl            : constant Node_Id := Unit_Declaration_Node (Subp);
3309       Original_Body   : Node_Id;
3310       Body_To_Analyze : Node_Id;
3311       Max_Size        : constant := 10;
3312       Stat_Count      : Integer := 0;
3313
3314       function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
3315       --  Check for declarations that make inlining not worthwhile
3316
3317       function Has_Excluded_Statement   (Stats : List_Id) return Boolean;
3318       --  Check for statements that make inlining not worthwhile: any tasking
3319       --  statement, nested at any level. Keep track of total number of
3320       --  elementary statements, as a measure of acceptable size.
3321
3322       function Has_Pending_Instantiation return Boolean;
3323       --  If some enclosing body contains instantiations that appear before the
3324       --  corresponding generic body, the enclosing body has a freeze node so
3325       --  that it can be elaborated after the generic itself. This might
3326       --  conflict with subsequent inlinings, so that it is unsafe to try to
3327       --  inline in such a case.
3328
3329       function Has_Single_Return return Boolean;
3330       --  In general we cannot inline functions that return unconstrained type.
3331       --  However, we can handle such functions if all return statements return
3332       --  a local variable that is the only declaration in the body of the
3333       --  function. In that case the call can be replaced by that local
3334       --  variable as is done for other inlined calls.
3335
3336       procedure Remove_Pragmas;
3337       --  A pragma Unreferenced or pragma Unmodified that mentions a formal
3338       --  parameter has no meaning when the body is inlined and the formals
3339       --  are rewritten. Remove it from body to inline. The analysis of the
3340       --  non-inlined body will handle the pragma properly.
3341
3342       function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
3343       --  If the body of the subprogram includes a call that returns an
3344       --  unconstrained type, the secondary stack is involved, and it
3345       --  is not worth inlining.
3346
3347       ------------------------------
3348       -- Has_Excluded_Declaration --
3349       ------------------------------
3350
3351       function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
3352          D : Node_Id;
3353
3354          function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
3355          --  Nested subprograms make a given body ineligible for inlining, but
3356          --  we make an exception for instantiations of unchecked conversion.
3357          --  The body has not been analyzed yet, so check the name, and verify
3358          --  that the visible entity with that name is the predefined unit.
3359
3360          -----------------------------
3361          -- Is_Unchecked_Conversion --
3362          -----------------------------
3363
3364          function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3365             Id   : constant Node_Id := Name (D);
3366             Conv : Entity_Id;
3367
3368          begin
3369             if Nkind (Id) = N_Identifier
3370               and then Chars (Id) = Name_Unchecked_Conversion
3371             then
3372                Conv := Current_Entity (Id);
3373
3374             elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3375               and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3376             then
3377                Conv := Current_Entity (Selector_Name (Id));
3378             else
3379                return False;
3380             end if;
3381
3382             return Present (Conv)
3383               and then Is_Predefined_File_Name
3384                          (Unit_File_Name (Get_Source_Unit (Conv)))
3385               and then Is_Intrinsic_Subprogram (Conv);
3386          end Is_Unchecked_Conversion;
3387
3388       --  Start of processing for Has_Excluded_Declaration
3389
3390       begin
3391          D := First (Decls);
3392          while Present (D) loop
3393             if (Nkind (D) = N_Function_Instantiation
3394                   and then not Is_Unchecked_Conversion (D))
3395               or else Nkind_In (D, N_Protected_Type_Declaration,
3396                                    N_Package_Declaration,
3397                                    N_Package_Instantiation,
3398                                    N_Subprogram_Body,
3399                                    N_Procedure_Instantiation,
3400                                    N_Task_Type_Declaration)
3401             then
3402                Cannot_Inline
3403                  ("cannot inline & (non-allowed declaration)?", D, Subp);
3404                return True;
3405             end if;
3406
3407             Next (D);
3408          end loop;
3409
3410          return False;
3411       end Has_Excluded_Declaration;
3412
3413       ----------------------------
3414       -- Has_Excluded_Statement --
3415       ----------------------------
3416
3417       function Has_Excluded_Statement (Stats : List_Id) return Boolean is
3418          S : Node_Id;
3419          E : Node_Id;
3420
3421       begin
3422          S := First (Stats);
3423          while Present (S) loop
3424             Stat_Count := Stat_Count + 1;
3425
3426             if Nkind_In (S, N_Abort_Statement,
3427                             N_Asynchronous_Select,
3428                             N_Conditional_Entry_Call,
3429                             N_Delay_Relative_Statement,
3430                             N_Delay_Until_Statement,
3431                             N_Selective_Accept,
3432                             N_Timed_Entry_Call)
3433             then
3434                Cannot_Inline
3435                  ("cannot inline & (non-allowed statement)?", S, Subp);
3436                return True;
3437
3438             elsif Nkind (S) = N_Block_Statement then
3439                if Present (Declarations (S))
3440                  and then Has_Excluded_Declaration (Declarations (S))
3441                then
3442                   return True;
3443
3444                elsif Present (Handled_Statement_Sequence (S))
3445                   and then
3446                     (Present
3447                       (Exception_Handlers (Handled_Statement_Sequence (S)))
3448                      or else
3449                        Has_Excluded_Statement
3450                          (Statements (Handled_Statement_Sequence (S))))
3451                then
3452                   return True;
3453                end if;
3454
3455             elsif Nkind (S) = N_Case_Statement then
3456                E := First (Alternatives (S));
3457                while Present (E) loop
3458                   if Has_Excluded_Statement (Statements (E)) then
3459                      return True;
3460                   end if;
3461
3462                   Next (E);
3463                end loop;
3464
3465             elsif Nkind (S) = N_If_Statement then
3466                if Has_Excluded_Statement (Then_Statements (S)) then
3467                   return True;
3468                end if;
3469
3470                if Present (Elsif_Parts (S)) then
3471                   E := First (Elsif_Parts (S));
3472                   while Present (E) loop
3473                      if Has_Excluded_Statement (Then_Statements (E)) then
3474                         return True;
3475                      end if;
3476                      Next (E);
3477                   end loop;
3478                end if;
3479
3480                if Present (Else_Statements (S))
3481                  and then Has_Excluded_Statement (Else_Statements (S))
3482                then
3483                   return True;
3484                end if;
3485
3486             elsif Nkind (S) = N_Loop_Statement
3487               and then Has_Excluded_Statement (Statements (S))
3488             then
3489                return True;
3490
3491             elsif Nkind (S) = N_Extended_Return_Statement then
3492                if Has_Excluded_Statement
3493                   (Statements (Handled_Statement_Sequence (S)))
3494                  or else Present
3495                    (Exception_Handlers (Handled_Statement_Sequence (S)))
3496                then
3497                   return True;
3498                end if;
3499             end if;
3500
3501             Next (S);
3502          end loop;
3503
3504          return False;
3505       end Has_Excluded_Statement;
3506
3507       -------------------------------
3508       -- Has_Pending_Instantiation --
3509       -------------------------------
3510
3511       function Has_Pending_Instantiation return Boolean is
3512          S : Entity_Id;
3513
3514       begin
3515          S := Current_Scope;
3516          while Present (S) loop
3517             if Is_Compilation_Unit (S)
3518               or else Is_Child_Unit (S)
3519             then
3520                return False;
3521
3522             elsif Ekind (S) = E_Package
3523               and then Has_Forward_Instantiation (S)
3524             then
3525                return True;
3526             end if;
3527
3528             S := Scope (S);
3529          end loop;
3530
3531          return False;
3532       end Has_Pending_Instantiation;
3533
3534       ------------------------
3535       --  Has_Single_Return --
3536       ------------------------
3537
3538       function Has_Single_Return return Boolean is
3539          Return_Statement : Node_Id := Empty;
3540
3541          function Check_Return (N : Node_Id) return Traverse_Result;
3542
3543          ------------------
3544          -- Check_Return --
3545          ------------------
3546
3547          function Check_Return (N : Node_Id) return Traverse_Result is
3548          begin
3549             if Nkind (N) = N_Simple_Return_Statement then
3550                if Present (Expression (N))
3551                  and then Is_Entity_Name (Expression (N))
3552                then
3553                   if No (Return_Statement) then
3554                      Return_Statement := N;
3555                      return OK;
3556
3557                   elsif Chars (Expression (N)) =
3558                         Chars (Expression (Return_Statement))
3559                   then
3560                      return OK;
3561
3562                   else
3563                      return Abandon;
3564                   end if;
3565
3566                --  A return statement within an extended return is a noop
3567                --  after inlining.
3568
3569                elsif No (Expression (N))
3570                  and then Nkind (Parent (Parent (N))) =
3571                  N_Extended_Return_Statement
3572                then
3573                   return OK;
3574
3575                else
3576                   --  Expression has wrong form
3577
3578                   return Abandon;
3579                end if;
3580
3581             --  We can only inline a build-in-place function if
3582             --  it has a single extended return.
3583
3584             elsif Nkind (N) = N_Extended_Return_Statement then
3585                if No (Return_Statement) then
3586                   Return_Statement := N;
3587                   return OK;
3588
3589                else
3590                   return Abandon;
3591                end if;
3592
3593             else
3594                return OK;
3595             end if;
3596          end Check_Return;
3597
3598          function Check_All_Returns is new Traverse_Func (Check_Return);
3599
3600       --  Start of processing for Has_Single_Return
3601
3602       begin
3603          if Check_All_Returns (N) /= OK then
3604             return False;
3605
3606          elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
3607             return True;
3608
3609          else
3610             return Present (Declarations (N))
3611               and then Present (First (Declarations (N)))
3612               and then Chars (Expression (Return_Statement)) =
3613                  Chars (Defining_Identifier (First (Declarations (N))));
3614          end if;
3615       end Has_Single_Return;
3616
3617       --------------------
3618       -- Remove_Pragmas --
3619       --------------------
3620
3621       procedure Remove_Pragmas is
3622          Decl : Node_Id;
3623          Nxt  : Node_Id;
3624
3625       begin
3626          Decl := First (Declarations (Body_To_Analyze));
3627          while Present (Decl) loop
3628             Nxt := Next (Decl);
3629
3630             if Nkind (Decl) = N_Pragma
3631               and then (Pragma_Name (Decl) = Name_Unreferenced
3632                           or else
3633                         Pragma_Name (Decl) = Name_Unmodified)
3634             then
3635                Remove (Decl);
3636             end if;
3637
3638             Decl := Nxt;
3639          end loop;
3640       end Remove_Pragmas;
3641
3642       --------------------------
3643       -- Uses_Secondary_Stack --
3644       --------------------------
3645
3646       function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
3647          function Check_Call (N : Node_Id) return Traverse_Result;
3648          --  Look for function calls that return an unconstrained type
3649
3650          ----------------
3651          -- Check_Call --
3652          ----------------
3653
3654          function Check_Call (N : Node_Id) return Traverse_Result is
3655          begin
3656             if Nkind (N) = N_Function_Call
3657               and then Is_Entity_Name (Name (N))
3658               and then Is_Composite_Type (Etype (Entity (Name (N))))
3659               and then not Is_Constrained (Etype (Entity (Name (N))))
3660             then
3661                Cannot_Inline
3662                  ("cannot inline & (call returns unconstrained type)?",
3663                     N, Subp);
3664                return Abandon;
3665             else
3666                return OK;
3667             end if;
3668          end Check_Call;
3669
3670          function Check_Calls is new Traverse_Func (Check_Call);
3671
3672       begin
3673          return Check_Calls (Bod) = Abandon;
3674       end Uses_Secondary_Stack;
3675
3676    --  Start of processing for Build_Body_To_Inline
3677
3678    begin
3679       --  Return immediately if done already
3680
3681       if Nkind (Decl) = N_Subprogram_Declaration
3682         and then Present (Body_To_Inline (Decl))
3683       then
3684          return;
3685
3686       --  Functions that return unconstrained composite types require
3687       --  secondary stack handling, and cannot currently be inlined, unless
3688       --  all return statements return a local variable that is the first
3689       --  local declaration in the body.
3690
3691       elsif Ekind (Subp) = E_Function
3692         and then not Is_Scalar_Type (Etype (Subp))
3693         and then not Is_Access_Type (Etype (Subp))
3694         and then not Is_Constrained (Etype (Subp))
3695       then
3696          if not Has_Single_Return then
3697             Cannot_Inline
3698               ("cannot inline & (unconstrained return type)?", N, Subp);
3699             return;
3700          end if;
3701
3702       --  Ditto for functions that return controlled types, where controlled
3703       --  actions interfere in complex ways with inlining.
3704
3705       elsif Ekind (Subp) = E_Function
3706         and then Needs_Finalization (Etype (Subp))
3707       then
3708          Cannot_Inline
3709            ("cannot inline & (controlled return type)?", N, Subp);
3710          return;
3711       end if;
3712
3713       if Present (Declarations (N))
3714         and then Has_Excluded_Declaration (Declarations (N))
3715       then
3716          return;
3717       end if;
3718
3719       if Present (Handled_Statement_Sequence (N)) then
3720          if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
3721             Cannot_Inline
3722               ("cannot inline& (exception handler)?",
3723                First (Exception_Handlers (Handled_Statement_Sequence (N))),
3724                Subp);
3725             return;
3726          elsif
3727            Has_Excluded_Statement
3728              (Statements (Handled_Statement_Sequence (N)))
3729          then
3730             return;
3731          end if;
3732       end if;
3733
3734       --  We do not inline a subprogram  that is too large, unless it is
3735       --  marked Inline_Always. This pragma does not suppress the other
3736       --  checks on inlining (forbidden declarations, handlers, etc).
3737
3738       if Stat_Count > Max_Size
3739         and then not Has_Pragma_Inline_Always (Subp)
3740       then
3741          Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
3742          return;
3743       end if;
3744
3745       if Has_Pending_Instantiation then
3746          Cannot_Inline
3747            ("cannot inline& (forward instance within enclosing body)?",
3748              N, Subp);
3749          return;
3750       end if;
3751
3752       --  Within an instance, the body to inline must be treated as a nested
3753       --  generic, so that the proper global references are preserved.
3754
3755       --  Note that we do not do this at the library level, because it is not
3756       --  needed, and furthermore this causes trouble if front end inlining
3757       --  is activated (-gnatN).
3758
3759       if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
3760          Save_Env (Scope (Current_Scope), Scope (Current_Scope));
3761          Original_Body := Copy_Generic_Node (N, Empty, True);
3762       else
3763          Original_Body := Copy_Separate_Tree (N);
3764       end if;
3765
3766       --  We need to capture references to the formals in order to substitute
3767       --  the actuals at the point of inlining, i.e. instantiation. To treat
3768       --  the formals as globals to the body to inline, we nest it within
3769       --  a dummy parameterless subprogram, declared within the real one.
3770       --  To avoid generating an internal name (which is never public, and
3771       --  which affects serial numbers of other generated names), we use
3772       --  an internal symbol that cannot conflict with user declarations.
3773
3774       Set_Parameter_Specifications (Specification (Original_Body), No_List);
3775       Set_Defining_Unit_Name
3776         (Specification (Original_Body),
3777           Make_Defining_Identifier (Sloc (N), Name_uParent));
3778       Set_Corresponding_Spec (Original_Body, Empty);
3779
3780       Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
3781
3782       --  Set return type of function, which is also global and does not need
3783       --  to be resolved.
3784
3785       if Ekind (Subp) = E_Function then
3786          Set_Result_Definition (Specification (Body_To_Analyze),
3787            New_Occurrence_Of (Etype (Subp), Sloc (N)));
3788       end if;
3789
3790       if No (Declarations (N)) then
3791          Set_Declarations (N, New_List (Body_To_Analyze));
3792       else
3793          Append (Body_To_Analyze, Declarations (N));
3794       end if;
3795
3796       Expander_Mode_Save_And_Set (False);
3797       Remove_Pragmas;
3798
3799       Analyze (Body_To_Analyze);
3800       Push_Scope (Defining_Entity (Body_To_Analyze));
3801       Save_Global_References (Original_Body);
3802       End_Scope;
3803       Remove (Body_To_Analyze);
3804
3805       Expander_Mode_Restore;
3806
3807       --  Restore environment if previously saved
3808
3809       if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
3810          Restore_Env;
3811       end if;
3812
3813       --  If secondary stk used there is no point in inlining. We have
3814       --  already issued the warning in this case, so nothing to do.
3815
3816       if Uses_Secondary_Stack (Body_To_Analyze) then
3817          return;
3818       end if;
3819
3820       Set_Body_To_Inline (Decl, Original_Body);
3821       Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
3822       Set_Is_Inlined (Subp);
3823    end Build_Body_To_Inline;
3824
3825    -------------------
3826    -- Cannot_Inline --
3827    -------------------
3828
3829    procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
3830    begin
3831       --  Do not emit warning if this is a predefined unit which is not the
3832       --  main unit. With validity checks enabled, some predefined subprograms
3833       --  may contain nested subprograms and become ineligible for inlining.
3834
3835       if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
3836         and then not In_Extended_Main_Source_Unit (Subp)
3837       then
3838          null;
3839
3840       elsif Has_Pragma_Inline_Always (Subp) then
3841
3842          --  Remove last character (question mark) to make this into an error,
3843          --  because the Inline_Always pragma cannot be obeyed.
3844
3845          Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
3846
3847       elsif Ineffective_Inline_Warnings then
3848          Error_Msg_NE (Msg, N, Subp);
3849       end if;
3850    end Cannot_Inline;
3851
3852    -----------------------
3853    -- Check_Conformance --
3854    -----------------------
3855
3856    procedure Check_Conformance
3857      (New_Id                   : Entity_Id;
3858       Old_Id                   : Entity_Id;
3859       Ctype                    : Conformance_Type;
3860       Errmsg                   : Boolean;
3861       Conforms                 : out Boolean;
3862       Err_Loc                  : Node_Id := Empty;
3863       Get_Inst                 : Boolean := False;
3864       Skip_Controlling_Formals : Boolean := False)
3865    is
3866       procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
3867       --  Sets Conforms to False. If Errmsg is False, then that's all it does.
3868       --  If Errmsg is True, then processing continues to post an error message
3869       --  for conformance error on given node. Two messages are output. The
3870       --  first message points to the previous declaration with a general "no
3871       --  conformance" message. The second is the detailed reason, supplied as
3872       --  Msg. The parameter N provide information for a possible & insertion
3873       --  in the message, and also provides the location for posting the
3874       --  message in the absence of a specified Err_Loc location.
3875
3876       -----------------------
3877       -- Conformance_Error --
3878       -----------------------
3879
3880       procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
3881          Enode : Node_Id;
3882
3883       begin
3884          Conforms := False;
3885
3886          if Errmsg then
3887             if No (Err_Loc) then
3888                Enode := N;
3889             else
3890                Enode := Err_Loc;
3891             end if;
3892
3893             Error_Msg_Sloc := Sloc (Old_Id);
3894
3895             case Ctype is
3896                when Type_Conformant =>
3897                   Error_Msg_N -- CODEFIX
3898                     ("not type conformant with declaration#!", Enode);
3899
3900                when Mode_Conformant =>
3901                   if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3902                      Error_Msg_N
3903                        ("not mode conformant with operation inherited#!",
3904                          Enode);
3905                   else
3906                      Error_Msg_N
3907                        ("not mode conformant with declaration#!", Enode);
3908                   end if;
3909
3910                when Subtype_Conformant =>
3911                   if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3912                      Error_Msg_N
3913                        ("not subtype conformant with operation inherited#!",
3914                          Enode);
3915                   else
3916                      Error_Msg_N
3917                        ("not subtype conformant with declaration#!", Enode);
3918                   end if;
3919
3920                when Fully_Conformant =>
3921                   if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
3922                      Error_Msg_N -- CODEFIX
3923                        ("not fully conformant with operation inherited#!",
3924                          Enode);
3925                   else
3926                      Error_Msg_N -- CODEFIX
3927                        ("not fully conformant with declaration#!", Enode);
3928                   end if;
3929             end case;
3930
3931             Error_Msg_NE (Msg, Enode, N);
3932          end if;
3933       end Conformance_Error;
3934
3935       --  Local Variables
3936
3937       Old_Type           : constant Entity_Id := Etype (Old_Id);
3938       New_Type           : constant Entity_Id := Etype (New_Id);
3939       Old_Formal         : Entity_Id;
3940       New_Formal         : Entity_Id;
3941       Access_Types_Match : Boolean;
3942       Old_Formal_Base    : Entity_Id;
3943       New_Formal_Base    : Entity_Id;
3944
3945    --  Start of processing for Check_Conformance
3946
3947    begin
3948       Conforms := True;
3949
3950       --  We need a special case for operators, since they don't appear
3951       --  explicitly.
3952
3953       if Ctype = Type_Conformant then
3954          if Ekind (New_Id) = E_Operator
3955            and then Operator_Matches_Spec (New_Id, Old_Id)
3956          then
3957             return;
3958          end if;
3959       end if;
3960
3961       --  If both are functions/operators, check return types conform
3962
3963       if Old_Type /= Standard_Void_Type
3964         and then New_Type /= Standard_Void_Type
3965       then
3966
3967          --  If we are checking interface conformance we omit controlling
3968          --  arguments and result, because we are only checking the conformance
3969          --  of the remaining parameters.
3970
3971          if Has_Controlling_Result (Old_Id)
3972            and then Has_Controlling_Result (New_Id)
3973            and then Skip_Controlling_Formals
3974          then
3975             null;
3976
3977          elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
3978             Conformance_Error ("\return type does not match!", New_Id);
3979             return;
3980          end if;
3981
3982          --  Ada 2005 (AI-231): In case of anonymous access types check the
3983          --  null-exclusion and access-to-constant attributes match.
3984
3985          if Ada_Version >= Ada_2005
3986            and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
3987            and then
3988              (Can_Never_Be_Null (Old_Type)
3989                 /= Can_Never_Be_Null (New_Type)
3990               or else Is_Access_Constant (Etype (Old_Type))
3991                         /= Is_Access_Constant (Etype (New_Type)))
3992          then
3993             Conformance_Error ("\return type does not match!", New_Id);
3994             return;
3995          end if;
3996
3997       --  If either is a function/operator and the other isn't, error
3998
3999       elsif Old_Type /= Standard_Void_Type
4000         or else New_Type /= Standard_Void_Type
4001       then
4002          Conformance_Error ("\functions can only match functions!", New_Id);
4003          return;
4004       end if;
4005
4006       --  In subtype conformant case, conventions must match (RM 6.3.1(16)).
4007       --  If this is a renaming as body, refine error message to indicate that
4008       --  the conflict is with the original declaration. If the entity is not
4009       --  frozen, the conventions don't have to match, the one of the renamed
4010       --  entity is inherited.
4011
4012       if Ctype >= Subtype_Conformant then
4013          if Convention (Old_Id) /= Convention (New_Id) then
4014
4015             if not Is_Frozen (New_Id) then
4016                null;
4017
4018             elsif Present (Err_Loc)
4019               and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
4020               and then Present (Corresponding_Spec (Err_Loc))
4021             then
4022                Error_Msg_Name_1 := Chars (New_Id);
4023                Error_Msg_Name_2 :=
4024                  Name_Ada + Convention_Id'Pos (Convention (New_Id));
4025                Conformance_Error ("\prior declaration for% has convention %!");
4026
4027             else
4028                Conformance_Error ("\calling conventions do not match!");
4029             end if;
4030
4031             return;
4032
4033          elsif Is_Formal_Subprogram (Old_Id)
4034            or else Is_Formal_Subprogram (New_Id)
4035          then
4036             Conformance_Error ("\formal subprograms not allowed!");
4037             return;
4038          end if;
4039       end if;
4040
4041       --  Deal with parameters
4042
4043       --  Note: we use the entity information, rather than going directly
4044       --  to the specification in the tree. This is not only simpler, but
4045       --  absolutely necessary for some cases of conformance tests between
4046       --  operators, where the declaration tree simply does not exist!
4047
4048       Old_Formal := First_Formal (Old_Id);
4049       New_Formal := First_Formal (New_Id);
4050       while Present (Old_Formal) and then Present (New_Formal) loop
4051          if Is_Controlling_Formal (Old_Formal)
4052            and then Is_Controlling_Formal (New_Formal)
4053            and then Skip_Controlling_Formals
4054          then
4055             --  The controlling formals will have different types when
4056             --  comparing an interface operation with its match, but both
4057             --  or neither must be access parameters.
4058
4059             if Is_Access_Type (Etype (Old_Formal))
4060                  =
4061                Is_Access_Type (Etype (New_Formal))
4062             then
4063                goto Skip_Controlling_Formal;
4064             else
4065                Conformance_Error
4066                  ("\access parameter does not match!", New_Formal);
4067             end if;
4068          end if;
4069
4070          if Ctype = Fully_Conformant then
4071
4072             --  Names must match. Error message is more accurate if we do
4073             --  this before checking that the types of the formals match.
4074
4075             if Chars (Old_Formal) /= Chars (New_Formal) then
4076                Conformance_Error ("\name & does not match!", New_Formal);
4077
4078                --  Set error posted flag on new formal as well to stop
4079                --  junk cascaded messages in some cases.
4080
4081                Set_Error_Posted (New_Formal);
4082                return;
4083             end if;
4084
4085             --  Null exclusion must match
4086
4087             if Null_Exclusion_Present (Parent (Old_Formal))
4088                  /=
4089                Null_Exclusion_Present (Parent (New_Formal))
4090             then
4091                --  Only give error if both come from source. This should be
4092                --  investigated some time, since it should not be needed ???
4093
4094                if Comes_From_Source (Old_Formal)
4095                     and then
4096                   Comes_From_Source (New_Formal)
4097                then
4098                   Conformance_Error
4099                     ("\null exclusion for & does not match", New_Formal);
4100
4101                   --  Mark error posted on the new formal to avoid duplicated
4102                   --  complaint about types not matching.
4103
4104                   Set_Error_Posted (New_Formal);
4105                end if;
4106             end if;
4107          end if;
4108
4109          --  Ada 2005 (AI-423): Possible access [sub]type and itype match. This
4110          --  case occurs whenever a subprogram is being renamed and one of its
4111          --  parameters imposes a null exclusion. For example:
4112
4113          --     type T is null record;
4114          --     type Acc_T is access T;
4115          --     subtype Acc_T_Sub is Acc_T;
4116
4117          --     procedure P     (Obj : not null Acc_T_Sub);  --  itype
4118          --     procedure Ren_P (Obj :          Acc_T_Sub)   --  subtype
4119          --       renames P;
4120
4121          Old_Formal_Base := Etype (Old_Formal);
4122          New_Formal_Base := Etype (New_Formal);
4123
4124          if Get_Inst then
4125             Old_Formal_Base := Get_Instance_Of (Old_Formal_Base);
4126             New_Formal_Base := Get_Instance_Of (New_Formal_Base);
4127          end if;
4128
4129          Access_Types_Match := Ada_Version >= Ada_2005
4130
4131             --  Ensure that this rule is only applied when New_Id is a
4132             --  renaming of Old_Id.
4133
4134            and then Nkind (Parent (Parent (New_Id))) =
4135                       N_Subprogram_Renaming_Declaration
4136            and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
4137            and then Present (Entity (Name (Parent (Parent (New_Id)))))
4138            and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
4139
4140             --  Now handle the allowed access-type case
4141
4142            and then Is_Access_Type (Old_Formal_Base)
4143            and then Is_Access_Type (New_Formal_Base)
4144
4145             --  The type kinds must match. The only exception occurs with
4146             --  multiple generics of the form:
4147
4148             --   generic                    generic
4149             --     type F is private;         type A is private;
4150             --     type F_Ptr is access F;    type A_Ptr is access A;
4151             --     with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
4152             --   package F_Pack is ...      package A_Pack is
4153             --                                package F_Inst is
4154             --                                  new F_Pack (A, A_Ptr, A_P);
4155
4156             --  When checking for conformance between the parameters of A_P
4157             --  and F_P, the type kinds of F_Ptr and A_Ptr will not match
4158             --  because the compiler has transformed A_Ptr into a subtype of
4159             --  F_Ptr. We catch this case in the code below.
4160
4161            and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
4162                   or else
4163                     (Is_Generic_Type (Old_Formal_Base)
4164                        and then Is_Generic_Type (New_Formal_Base)
4165                        and then Is_Internal (New_Formal_Base)
4166                        and then Etype (Etype (New_Formal_Base)) =
4167                                   Old_Formal_Base))
4168            and then Directly_Designated_Type (Old_Formal_Base) =
4169                       Directly_Designated_Type (New_Formal_Base)
4170            and then ((Is_Itype (Old_Formal_Base)
4171                        and then Can_Never_Be_Null (Old_Formal_Base))
4172                     or else
4173                      (Is_Itype (New_Formal_Base)
4174                        and then Can_Never_Be_Null (New_Formal_Base)));
4175
4176          --  Types must always match. In the visible part of an instance,
4177          --  usual overloading rules for dispatching operations apply, and
4178          --  we check base types (not the actual subtypes).
4179
4180          if In_Instance_Visible_Part
4181            and then Is_Dispatching_Operation (New_Id)
4182          then
4183             if not Conforming_Types
4184                      (T1       => Base_Type (Etype (Old_Formal)),
4185                       T2       => Base_Type (Etype (New_Formal)),
4186                       Ctype    => Ctype,
4187                       Get_Inst => Get_Inst)
4188                and then not Access_Types_Match
4189             then
4190                Conformance_Error ("\type of & does not match!", New_Formal);
4191                return;
4192             end if;
4193
4194          elsif not Conforming_Types
4195                      (T1       => Old_Formal_Base,
4196                       T2       => New_Formal_Base,
4197                       Ctype    => Ctype,
4198                       Get_Inst => Get_Inst)
4199            and then not Access_Types_Match
4200          then
4201             --  Don't give error message if old type is Any_Type. This test
4202             --  avoids some cascaded errors, e.g. in case of a bad spec.
4203
4204             if Errmsg and then Old_Formal_Base = Any_Type then
4205                Conforms := False;
4206             else
4207                Conformance_Error ("\type of & does not match!", New_Formal);
4208             end if;
4209
4210             return;
4211          end if;
4212
4213          --  For mode conformance, mode must match
4214
4215          if Ctype >= Mode_Conformant then
4216             if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
4217                Conformance_Error ("\mode of & does not match!", New_Formal);
4218                return;
4219
4220             --  Part of mode conformance for access types is having the same
4221             --  constant modifier.
4222
4223             elsif Access_Types_Match
4224               and then Is_Access_Constant (Old_Formal_Base) /=
4225                        Is_Access_Constant (New_Formal_Base)
4226             then
4227                Conformance_Error
4228                  ("\constant modifier does not match!", New_Formal);
4229                return;
4230             end if;
4231          end if;
4232
4233          if Ctype >= Subtype_Conformant then
4234
4235             --  Ada 2005 (AI-231): In case of anonymous access types check
4236             --  the null-exclusion and access-to-constant attributes must
4237             --  match. For null exclusion, we test the types rather than the
4238             --  formals themselves, since the attribute is only set reliably
4239             --  on the formals in the Ada 95 case, and we exclude the case
4240             --  where Old_Formal is marked as controlling, to avoid errors
4241             --  when matching completing bodies with dispatching declarations
4242             --  (access formals in the bodies aren't marked Can_Never_Be_Null).
4243
4244             if Ada_Version >= Ada_2005
4245               and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
4246               and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type
4247               and then
4248                 ((Can_Never_Be_Null (Etype (Old_Formal)) /=
4249                   Can_Never_Be_Null (Etype (New_Formal))
4250                     and then
4251                       not Is_Controlling_Formal (Old_Formal))
4252                    or else
4253                  Is_Access_Constant (Etype (Old_Formal)) /=
4254                  Is_Access_Constant (Etype (New_Formal)))
4255
4256               --  Do not complain if error already posted on New_Formal. This
4257               --  avoids some redundant error messages.
4258
4259               and then not Error_Posted (New_Formal)
4260             then
4261                --  It is allowed to omit the null-exclusion in case of stream
4262                --  attribute subprograms. We recognize stream subprograms
4263                --  through their TSS-generated suffix.
4264
4265                declare
4266                   TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id);
4267                begin
4268                   if TSS_Name /= TSS_Stream_Read
4269                     and then TSS_Name /= TSS_Stream_Write
4270                     and then TSS_Name /= TSS_Stream_Input
4271                     and then TSS_Name /= TSS_Stream_Output
4272                   then
4273                      Conformance_Error
4274                        ("\type of & does not match!", New_Formal);
4275                      return;
4276                   end if;
4277                end;
4278             end if;
4279          end if;
4280
4281          --  Full conformance checks
4282
4283          if Ctype = Fully_Conformant then
4284
4285             --  We have checked already that names match
4286
4287             if Parameter_Mode (Old_Formal) = E_In_Parameter then
4288
4289                --  Check default expressions for in parameters
4290
4291                declare
4292                   NewD : constant Boolean :=
4293                            Present (Default_Value (New_Formal));
4294                   OldD : constant Boolean :=
4295                            Present (Default_Value (Old_Formal));
4296                begin
4297                   if NewD or OldD then
4298
4299                      --  The old default value has been analyzed because the
4300                      --  current full declaration will have frozen everything
4301                      --  before. The new default value has not been analyzed,
4302                      --  so analyze it now before we check for conformance.
4303
4304                      if NewD then
4305                         Push_Scope (New_Id);
4306                         Preanalyze_Spec_Expression
4307                           (Default_Value (New_Formal), Etype (New_Formal));
4308                         End_Scope;
4309                      end if;
4310
4311                      if not (NewD and OldD)
4312                        or else not Fully_Conformant_Expressions
4313                                     (Default_Value (Old_Formal),
4314                                      Default_Value (New_Formal))
4315                      then
4316                         Conformance_Error
4317                           ("\default expression for & does not match!",
4318                            New_Formal);
4319                         return;
4320                      end if;
4321                   end if;
4322                end;
4323             end if;
4324          end if;
4325
4326          --  A couple of special checks for Ada 83 mode. These checks are
4327          --  skipped if either entity is an operator in package Standard,
4328          --  or if either old or new instance is not from the source program.
4329
4330          if Ada_Version = Ada_83
4331            and then Sloc (Old_Id) > Standard_Location
4332            and then Sloc (New_Id) > Standard_Location
4333            and then Comes_From_Source (Old_Id)
4334            and then Comes_From_Source (New_Id)
4335          then
4336             declare
4337                Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
4338                New_Param : constant Node_Id := Declaration_Node (New_Formal);
4339
4340             begin
4341                --  Explicit IN must be present or absent in both cases. This
4342                --  test is required only in the full conformance case.
4343
4344                if In_Present (Old_Param) /= In_Present (New_Param)
4345                  and then Ctype = Fully_Conformant
4346                then
4347                   Conformance_Error
4348                     ("\(Ada 83) IN must appear in both declarations",
4349                      New_Formal);
4350                   return;
4351                end if;
4352
4353                --  Grouping (use of comma in param lists) must be the same
4354                --  This is where we catch a misconformance like:
4355
4356                --    A, B : Integer
4357                --    A : Integer; B : Integer
4358
4359                --  which are represented identically in the tree except
4360                --  for the setting of the flags More_Ids and Prev_Ids.
4361
4362                if More_Ids (Old_Param) /= More_Ids (New_Param)
4363                  or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
4364                then
4365                   Conformance_Error
4366                     ("\grouping of & does not match!", New_Formal);
4367                   return;
4368                end if;
4369             end;
4370          end if;
4371
4372          --  This label is required when skipping controlling formals
4373
4374          <<Skip_Controlling_Formal>>
4375
4376          Next_Formal (Old_Formal);
4377          Next_Formal (New_Formal);
4378       end loop;
4379
4380       if Present (Old_Formal) then
4381          Conformance_Error ("\too few parameters!");
4382          return;
4383
4384       elsif Present (New_Formal) then
4385          Conformance_Error ("\too many parameters!", New_Formal);
4386          return;
4387       end if;
4388    end Check_Conformance;
4389
4390    -----------------------
4391    -- Check_Conventions --
4392    -----------------------
4393
4394    procedure Check_Conventions (Typ : Entity_Id) is
4395       Ifaces_List : Elist_Id;
4396
4397       procedure Check_Convention (Op : Entity_Id);
4398       --  Verify that the convention of inherited dispatching operation Op is
4399       --  consistent among all subprograms it overrides. In order to minimize
4400       --  the search, Search_From is utilized to designate a specific point in
4401       --  the list rather than iterating over the whole list once more.
4402
4403       ----------------------
4404       -- Check_Convention --
4405       ----------------------
4406
4407       procedure Check_Convention (Op : Entity_Id) is
4408          Iface_Elmt      : Elmt_Id;
4409          Iface_Prim_Elmt : Elmt_Id;
4410          Iface_Prim      : Entity_Id;
4411
4412       begin
4413          Iface_Elmt := First_Elmt (Ifaces_List);
4414          while Present (Iface_Elmt) loop
4415             Iface_Prim_Elmt :=
4416                First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
4417             while Present (Iface_Prim_Elmt) loop
4418                Iface_Prim := Node (Iface_Prim_Elmt);
4419
4420                if Is_Interface_Conformant (Typ, Iface_Prim, Op)
4421                  and then Convention (Iface_Prim) /= Convention (Op)
4422                then
4423                   Error_Msg_N
4424                     ("inconsistent conventions in primitive operations", Typ);
4425
4426                   Error_Msg_Name_1 := Chars (Op);
4427                   Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
4428                   Error_Msg_Sloc   := Sloc (Op);
4429
4430                   if Comes_From_Source (Op) or else No (Alias (Op)) then
4431                      if not Present (Overridden_Operation (Op)) then
4432                         Error_Msg_N ("\\primitive % defined #", Typ);
4433                      else
4434                         Error_Msg_N
4435                           ("\\overriding operation % with " &
4436                            "convention % defined #", Typ);
4437                      end if;
4438
4439                   else pragma Assert (Present (Alias (Op)));
4440                      Error_Msg_Sloc := Sloc (Alias (Op));
4441                      Error_Msg_N
4442                        ("\\inherited operation % with " &
4443                         "convention % defined #", Typ);
4444                   end if;
4445
4446                   Error_Msg_Name_1 := Chars (Op);
4447                   Error_Msg_Name_2 :=
4448                     Get_Convention_Name (Convention (Iface_Prim));
4449                   Error_Msg_Sloc := Sloc (Iface_Prim);
4450                   Error_Msg_N
4451                     ("\\overridden operation % with " &
4452                      "convention % defined #", Typ);
4453
4454                   --  Avoid cascading errors
4455
4456                   return;
4457                end if;
4458
4459                Next_Elmt (Iface_Prim_Elmt);
4460             end loop;
4461
4462             Next_Elmt (Iface_Elmt);
4463          end loop;
4464       end Check_Convention;
4465
4466       --  Local variables
4467
4468       Prim_Op      : Entity_Id;
4469       Prim_Op_Elmt : Elmt_Id;
4470
4471    --  Start of processing for Check_Conventions
4472
4473    begin
4474       if not Has_Interfaces (Typ) then
4475          return;
4476       end if;
4477
4478       Collect_Interfaces (Typ, Ifaces_List);
4479
4480       --  The algorithm checks every overriding dispatching operation against
4481       --  all the corresponding overridden dispatching operations, detecting
4482       --  differences in conventions.
4483
4484       Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ));
4485       while Present (Prim_Op_Elmt) loop
4486          Prim_Op := Node (Prim_Op_Elmt);
4487
4488          --  A small optimization: skip the predefined dispatching operations
4489          --  since they always have the same convention.
4490
4491          if not Is_Predefined_Dispatching_Operation (Prim_Op) then
4492             Check_Convention (Prim_Op);
4493          end if;
4494
4495          Next_Elmt (Prim_Op_Elmt);
4496       end loop;
4497    end Check_Conventions;
4498
4499    ------------------------------
4500    -- Check_Delayed_Subprogram --
4501    ------------------------------
4502
4503    procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
4504       F : Entity_Id;
4505
4506       procedure Possible_Freeze (T : Entity_Id);
4507       --  T is the type of either a formal parameter or of the return type.
4508       --  If T is not yet frozen and needs a delayed freeze, then the
4509       --  subprogram itself must be delayed. If T is the limited view of an
4510       --  incomplete type the subprogram must be frozen as well, because
4511       --  T may depend on local types that have not been frozen yet.
4512
4513       ---------------------
4514       -- Possible_Freeze --
4515       ---------------------
4516
4517       procedure Possible_Freeze (T : Entity_Id) is
4518       begin
4519          if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
4520             Set_Has_Delayed_Freeze (Designator);
4521
4522          elsif Is_Access_Type (T)
4523            and then Has_Delayed_Freeze (Designated_Type (T))
4524            and then not Is_Frozen (Designated_Type (T))
4525          then
4526             Set_Has_Delayed_Freeze (Designator);
4527
4528          elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then
4529             Set_Has_Delayed_Freeze (Designator);
4530
4531          --  AI05-0151: In Ada 2012, Incomplete types can appear in the profile
4532          --  of a subprogram or entry declaration.
4533
4534          elsif Ekind (T) = E_Incomplete_Type
4535            and then Ada_Version >= Ada_2012
4536          then
4537             Set_Has_Delayed_Freeze (Designator);
4538          end if;
4539
4540       end Possible_Freeze;
4541
4542    --  Start of processing for Check_Delayed_Subprogram
4543
4544    begin
4545       --  All subprograms, including abstract subprograms, may need a freeze
4546       --  node if some formal type or the return type needs one.
4547
4548       Possible_Freeze (Etype (Designator));
4549       Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
4550
4551       --  Need delayed freeze if any of the formal types themselves need
4552       --  a delayed freeze and are not yet frozen.
4553
4554       F := First_Formal (Designator);
4555       while Present (F) loop
4556          Possible_Freeze (Etype (F));
4557          Possible_Freeze (Base_Type (Etype (F))); -- needed ???
4558          Next_Formal (F);
4559       end loop;
4560
4561       --  Mark functions that return by reference. Note that it cannot be
4562       --  done for delayed_freeze subprograms because the underlying
4563       --  returned type may not be known yet (for private types)
4564
4565       if not Has_Delayed_Freeze (Designator)
4566         and then Expander_Active
4567       then
4568          declare
4569             Typ  : constant Entity_Id := Etype (Designator);
4570             Utyp : constant Entity_Id := Underlying_Type (Typ);
4571
4572          begin
4573             if Is_Immutably_Limited_Type (Typ) then
4574                Set_Returns_By_Ref (Designator);
4575
4576             elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
4577                Set_Returns_By_Ref (Designator);
4578             end if;
4579          end;
4580       end if;
4581    end Check_Delayed_Subprogram;
4582
4583    ------------------------------------
4584    -- Check_Discriminant_Conformance --
4585    ------------------------------------
4586
4587    procedure Check_Discriminant_Conformance
4588      (N        : Node_Id;
4589       Prev     : Entity_Id;
4590       Prev_Loc : Node_Id)
4591    is
4592       Old_Discr      : Entity_Id := First_Discriminant (Prev);
4593       New_Discr      : Node_Id   := First (Discriminant_Specifications (N));
4594       New_Discr_Id   : Entity_Id;
4595       New_Discr_Type : Entity_Id;
4596
4597       procedure Conformance_Error (Msg : String; N : Node_Id);
4598       --  Post error message for conformance error on given node. Two messages
4599       --  are output. The first points to the previous declaration with a
4600       --  general "no conformance" message. The second is the detailed reason,
4601       --  supplied as Msg. The parameter N provide information for a possible
4602       --  & insertion in the message.
4603
4604       -----------------------
4605       -- Conformance_Error --
4606       -----------------------
4607
4608       procedure Conformance_Error (Msg : String; N : Node_Id) is
4609       begin
4610          Error_Msg_Sloc := Sloc (Prev_Loc);
4611          Error_Msg_N -- CODEFIX
4612            ("not fully conformant with declaration#!", N);
4613          Error_Msg_NE (Msg, N, N);
4614       end Conformance_Error;
4615
4616    --  Start of processing for Check_Discriminant_Conformance
4617
4618    begin
4619       while Present (Old_Discr) and then Present (New_Discr) loop
4620
4621          New_Discr_Id := Defining_Identifier (New_Discr);
4622
4623          --  The subtype mark of the discriminant on the full type has not
4624          --  been analyzed so we do it here. For an access discriminant a new
4625          --  type is created.
4626
4627          if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
4628             New_Discr_Type :=
4629               Access_Definition (N, Discriminant_Type (New_Discr));
4630
4631          else
4632             Analyze (Discriminant_Type (New_Discr));
4633             New_Discr_Type := Etype (Discriminant_Type (New_Discr));
4634
4635             --  Ada 2005: if the discriminant definition carries a null
4636             --  exclusion, create an itype to check properly for consistency
4637             --  with partial declaration.
4638
4639             if Is_Access_Type (New_Discr_Type)
4640                  and then Null_Exclusion_Present (New_Discr)
4641             then
4642                New_Discr_Type :=
4643                  Create_Null_Excluding_Itype
4644                    (T           => New_Discr_Type,
4645                     Related_Nod => New_Discr,
4646                     Scope_Id    => Current_Scope);
4647             end if;
4648          end if;
4649
4650          if not Conforming_Types
4651                   (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
4652          then
4653             Conformance_Error ("type of & does not match!", New_Discr_Id);
4654             return;
4655          else
4656             --  Treat the new discriminant as an occurrence of the old one,
4657             --  for navigation purposes, and fill in some semantic
4658             --  information, for completeness.
4659
4660             Generate_Reference (Old_Discr, New_Discr_Id, 'r');
4661             Set_Etype (New_Discr_Id, Etype (Old_Discr));
4662             Set_Scope (New_Discr_Id, Scope (Old_Discr));
4663          end if;
4664
4665          --  Names must match
4666
4667          if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
4668             Conformance_Error ("name & does not match!", New_Discr_Id);
4669             return;
4670          end if;
4671
4672          --  Default expressions must match
4673
4674          declare
4675             NewD : constant Boolean :=
4676                      Present (Expression (New_Discr));
4677             OldD : constant Boolean :=
4678                      Present (Expression (Parent (Old_Discr)));
4679
4680          begin
4681             if NewD or OldD then
4682
4683                --  The old default value has been analyzed and expanded,
4684                --  because the current full declaration will have frozen
4685                --  everything before. The new default values have not been
4686                --  expanded, so expand now to check conformance.
4687
4688                if NewD then
4689                   Preanalyze_Spec_Expression
4690                     (Expression (New_Discr), New_Discr_Type);
4691                end if;
4692
4693                if not (NewD and OldD)
4694                  or else not Fully_Conformant_Expressions
4695                               (Expression (Parent (Old_Discr)),
4696                                Expression (New_Discr))
4697
4698                then
4699                   Conformance_Error
4700                     ("default expression for & does not match!",
4701                      New_Discr_Id);
4702                   return;
4703                end if;
4704             end if;
4705          end;
4706
4707          --  In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
4708
4709          if Ada_Version = Ada_83 then
4710             declare
4711                Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
4712
4713             begin
4714                --  Grouping (use of comma in param lists) must be the same
4715                --  This is where we catch a misconformance like:
4716
4717                --    A,B : Integer
4718                --    A : Integer; B : Integer
4719
4720                --  which are represented identically in the tree except
4721                --  for the setting of the flags More_Ids and Prev_Ids.
4722
4723                if More_Ids (Old_Disc) /= More_Ids (New_Discr)
4724                  or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
4725                then
4726                   Conformance_Error
4727                     ("grouping of & does not match!", New_Discr_Id);
4728                   return;
4729                end if;
4730             end;
4731          end if;
4732
4733          Next_Discriminant (Old_Discr);
4734          Next (New_Discr);
4735       end loop;
4736
4737       if Present (Old_Discr) then
4738          Conformance_Error ("too few discriminants!", Defining_Identifier (N));
4739          return;
4740
4741       elsif Present (New_Discr) then
4742          Conformance_Error
4743            ("too many discriminants!", Defining_Identifier (New_Discr));
4744          return;
4745       end if;
4746    end Check_Discriminant_Conformance;
4747
4748    ----------------------------
4749    -- Check_Fully_Conformant --
4750    ----------------------------
4751
4752    procedure Check_Fully_Conformant
4753      (New_Id  : Entity_Id;
4754       Old_Id  : Entity_Id;
4755       Err_Loc : Node_Id := Empty)
4756    is
4757       Result : Boolean;
4758       pragma Warnings (Off, Result);
4759    begin
4760       Check_Conformance
4761         (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
4762    end Check_Fully_Conformant;
4763
4764    ---------------------------
4765    -- Check_Mode_Conformant --
4766    ---------------------------
4767
4768    procedure Check_Mode_Conformant
4769      (New_Id   : Entity_Id;
4770       Old_Id   : Entity_Id;
4771       Err_Loc  : Node_Id := Empty;
4772       Get_Inst : Boolean := False)
4773    is
4774       Result : Boolean;
4775       pragma Warnings (Off, Result);
4776    begin
4777       Check_Conformance
4778         (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
4779    end Check_Mode_Conformant;
4780
4781    --------------------------------
4782    -- Check_Overriding_Indicator --
4783    --------------------------------
4784
4785    procedure Check_Overriding_Indicator
4786      (Subp            : Entity_Id;
4787       Overridden_Subp : Entity_Id;
4788       Is_Primitive    : Boolean)
4789    is
4790       Decl : Node_Id;
4791       Spec : Node_Id;
4792
4793    begin
4794       --  No overriding indicator for literals
4795
4796       if Ekind (Subp) = E_Enumeration_Literal then
4797          return;
4798
4799       elsif Ekind (Subp) = E_Entry then
4800          Decl := Parent (Subp);
4801
4802          --  No point in analyzing a malformed operator
4803
4804       elsif Nkind (Subp) = N_Defining_Operator_Symbol
4805         and then Error_Posted (Subp)
4806       then
4807          return;
4808
4809       else
4810          Decl := Unit_Declaration_Node (Subp);
4811       end if;
4812
4813       if Nkind_In (Decl, N_Subprogram_Body,
4814                          N_Subprogram_Body_Stub,
4815                          N_Subprogram_Declaration,
4816                          N_Abstract_Subprogram_Declaration,
4817                          N_Subprogram_Renaming_Declaration)
4818       then
4819          Spec := Specification (Decl);
4820
4821       elsif Nkind (Decl) = N_Entry_Declaration then
4822          Spec := Decl;
4823
4824       else
4825          return;
4826       end if;
4827
4828       --  The overriding operation is type conformant with the overridden one,
4829       --  but the names of the formals are not required to match. If the names
4830       --  appear permuted in the overriding operation, this is a possible
4831       --  source of confusion that is worth diagnosing. Controlling formals
4832       --  often carry names that reflect the type, and it is not worthwhile
4833       --  requiring that their names match.
4834
4835       if Present (Overridden_Subp)
4836         and then Nkind (Subp) /= N_Defining_Operator_Symbol
4837       then
4838          declare
4839             Form1 : Entity_Id;
4840             Form2 : Entity_Id;
4841
4842          begin
4843             Form1 := First_Formal (Subp);
4844             Form2 := First_Formal (Overridden_Subp);
4845
4846             --  If the overriding operation is a synchronized operation, skip
4847             --  the first parameter of the overridden operation, which is
4848             --  implicit in the new one. If the operation is declared in the
4849             --  body it is not primitive and all formals must match.
4850
4851             if Is_Concurrent_Type (Scope (Subp))
4852               and then Is_Tagged_Type (Scope (Subp))
4853               and then not Has_Completion (Scope (Subp))
4854             then
4855                Form2 := Next_Formal (Form2);
4856             end if;
4857
4858             if Present (Form1) then
4859                Form1 := Next_Formal (Form1);
4860                Form2 := Next_Formal (Form2);
4861             end if;
4862
4863             while Present (Form1) loop
4864                if not Is_Controlling_Formal (Form1)
4865                  and then Present (Next_Formal (Form2))
4866                  and then Chars (Form1) = Chars (Next_Formal (Form2))
4867                then
4868                   Error_Msg_Node_2 := Alias (Overridden_Subp);
4869                   Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
4870                   Error_Msg_NE
4871                     ("& does not match corresponding formal of&#",
4872                      Form1, Form1);
4873                   exit;
4874                end if;
4875
4876                Next_Formal (Form1);
4877                Next_Formal (Form2);
4878             end loop;
4879          end;
4880       end if;
4881
4882       --  If there is an overridden subprogram, then check that there is no
4883       --  "not overriding" indicator, and mark the subprogram as overriding.
4884       --  This is not done if the overridden subprogram is marked as hidden,
4885       --  which can occur for the case of inherited controlled operations
4886       --  (see Derive_Subprogram), unless the inherited subprogram's parent
4887       --  subprogram is not itself hidden. (Note: This condition could probably
4888       --  be simplified, leaving out the testing for the specific controlled
4889       --  cases, but it seems safer and clearer this way, and echoes similar
4890       --  special-case tests of this kind in other places.)
4891
4892       if Present (Overridden_Subp)
4893         and then (not Is_Hidden (Overridden_Subp)
4894                    or else
4895                      ((Chars (Overridden_Subp) = Name_Initialize
4896                          or else
4897                        Chars (Overridden_Subp) = Name_Adjust
4898                          or else
4899                        Chars (Overridden_Subp) = Name_Finalize)
4900                       and then Present (Alias (Overridden_Subp))
4901                       and then not Is_Hidden (Alias (Overridden_Subp))))
4902       then
4903          if Must_Not_Override (Spec) then
4904             Error_Msg_Sloc := Sloc (Overridden_Subp);
4905
4906             if Ekind (Subp) = E_Entry then
4907                Error_Msg_NE
4908                  ("entry & overrides inherited operation #", Spec, Subp);
4909             else
4910                Error_Msg_NE
4911                  ("subprogram & overrides inherited operation #", Spec, Subp);
4912             end if;
4913
4914          elsif Is_Subprogram (Subp) then
4915             if Is_Init_Proc (Subp) then
4916                null;
4917
4918             elsif No (Overridden_Operation (Subp)) then
4919
4920                --  For entities generated by Derive_Subprograms the overridden
4921                --  operation is the inherited primitive (which is available
4922                --  through the attribute alias)
4923
4924                if (Is_Dispatching_Operation (Subp)
4925                     or else Is_Dispatching_Operation (Overridden_Subp))
4926                  and then not Comes_From_Source (Overridden_Subp)
4927                  and then Find_Dispatching_Type (Overridden_Subp) =
4928                           Find_Dispatching_Type (Subp)
4929                  and then Present (Alias (Overridden_Subp))
4930                  and then Comes_From_Source (Alias (Overridden_Subp))
4931                then
4932                   Set_Overridden_Operation (Subp, Alias (Overridden_Subp));
4933
4934                else
4935                   Set_Overridden_Operation (Subp, Overridden_Subp);
4936                end if;
4937             end if;
4938          end if;
4939
4940          --  If primitive flag is set or this is a protected operation, then
4941          --  the operation is overriding at the point of its declaration, so
4942          --  warn if necessary. Otherwise it may have been declared before the
4943          --  operation it overrides and no check is required.
4944
4945          if Style_Check
4946            and then not Must_Override (Spec)
4947            and then (Is_Primitive
4948                       or else Ekind (Scope (Subp)) = E_Protected_Type)
4949          then
4950             Style.Missing_Overriding (Decl, Subp);
4951          end if;
4952
4953       --  If Subp is an operator, it may override a predefined operation, if
4954       --  it is defined in the same scope as the type to which it applies.
4955       --  In that case Overridden_Subp is empty because of our implicit
4956       --  representation for predefined operators. We have to check whether the
4957       --  signature of Subp matches that of a predefined operator. Note that
4958       --  first argument provides the name of the operator, and the second
4959       --  argument the signature that may match that of a standard operation.
4960       --  If the indicator is overriding, then the operator must match a
4961       --  predefined signature, because we know already that there is no
4962       --  explicit overridden operation.
4963
4964       elsif Nkind (Subp) = N_Defining_Operator_Symbol then
4965          if Must_Not_Override (Spec) then
4966
4967             --  If this is not a primitive or a protected subprogram, then
4968             --  "not overriding" is illegal.
4969
4970             if not Is_Primitive
4971               and then Ekind (Scope (Subp)) /= E_Protected_Type
4972             then
4973                Error_Msg_N
4974                  ("overriding indicator only allowed "
4975                   & "if subprogram is primitive", Subp);
4976
4977             elsif Can_Override_Operator (Subp) then
4978                Error_Msg_NE
4979                  ("subprogram& overrides predefined operator ", Spec, Subp);
4980             end if;
4981
4982          elsif Must_Override (Spec) then
4983             if No (Overridden_Operation (Subp))
4984               and then not Can_Override_Operator (Subp)
4985             then
4986                Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
4987             end if;
4988
4989          elsif not Error_Posted (Subp)
4990            and then Style_Check
4991            and then Can_Override_Operator (Subp)
4992            and then
4993              not Is_Predefined_File_Name
4994                    (Unit_File_Name (Get_Source_Unit (Subp)))
4995          then
4996             --  If style checks are enabled, indicate that the indicator is
4997             --  missing. However, at the point of declaration, the type of
4998             --  which this is a primitive operation may be private, in which
4999             --  case the indicator would be premature.
5000
5001             if Has_Private_Declaration (Etype (Subp))
5002               or else Has_Private_Declaration (Etype (First_Formal (Subp)))
5003             then
5004                null;
5005             else
5006                Style.Missing_Overriding (Decl, Subp);
5007             end if;
5008          end if;
5009
5010       elsif Must_Override (Spec) then
5011          if Ekind (Subp) = E_Entry then
5012             Error_Msg_NE ("entry & is not overriding", Spec, Subp);
5013          else
5014             Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
5015          end if;
5016
5017       --  If the operation is marked "not overriding" and it's not primitive
5018       --  then an error is issued, unless this is an operation of a task or
5019       --  protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
5020       --  has been specified have already been checked above.
5021
5022       elsif Must_Not_Override (Spec)
5023         and then not Is_Primitive
5024         and then Ekind (Subp) /= E_Entry
5025         and then Ekind (Scope (Subp)) /= E_Protected_Type
5026       then
5027          Error_Msg_N
5028            ("overriding indicator only allowed if subprogram is primitive",
5029             Subp);
5030          return;
5031       end if;
5032    end Check_Overriding_Indicator;
5033
5034    -------------------
5035    -- Check_Returns --
5036    -------------------
5037
5038    --  Note: this procedure needs to know far too much about how the expander
5039    --  messes with exceptions. The use of the flag Exception_Junk and the
5040    --  incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
5041    --  works, but is not very clean. It would be better if the expansion
5042    --  routines would leave Original_Node working nicely, and we could use
5043    --  Original_Node here to ignore all the peculiar expander messing ???
5044
5045    procedure Check_Returns
5046      (HSS  : Node_Id;
5047       Mode : Character;
5048       Err  : out Boolean;
5049       Proc : Entity_Id := Empty)
5050    is
5051       Handler : Node_Id;
5052
5053       procedure Check_Statement_Sequence (L : List_Id);
5054       --  Internal recursive procedure to check a list of statements for proper
5055       --  termination by a return statement (or a transfer of control or a
5056       --  compound statement that is itself internally properly terminated).
5057
5058       ------------------------------
5059       -- Check_Statement_Sequence --
5060       ------------------------------
5061
5062       procedure Check_Statement_Sequence (L : List_Id) is
5063          Last_Stm : Node_Id;
5064          Stm      : Node_Id;
5065          Kind     : Node_Kind;
5066
5067          Raise_Exception_Call : Boolean;
5068          --  Set True if statement sequence terminated by Raise_Exception call
5069          --  or a Reraise_Occurrence call.
5070
5071       begin
5072          Raise_Exception_Call := False;
5073
5074          --  Get last real statement
5075
5076          Last_Stm := Last (L);
5077
5078          --  Deal with digging out exception handler statement sequences that
5079          --  have been transformed by the local raise to goto optimization.
5080          --  See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
5081          --  optimization has occurred, we are looking at something like:
5082
5083          --  begin
5084          --     original stmts in block
5085
5086          --  exception            \
5087          --     when excep1 =>     |
5088          --        goto L1;        | omitted if No_Exception_Propagation
5089          --     when excep2 =>     |
5090          --        goto L2;       /
5091          --  end;
5092
5093          --  goto L3;      -- skip handler when exception not raised
5094
5095          --  <<L1>>        -- target label for local exception
5096          --     begin
5097          --        estmts1
5098          --     end;
5099
5100          --     goto L3;
5101
5102          --  <<L2>>
5103          --     begin
5104          --        estmts2
5105          --     end;
5106
5107          --  <<L3>>
5108
5109          --  and what we have to do is to dig out the estmts1 and estmts2
5110          --  sequences (which were the original sequences of statements in
5111          --  the exception handlers) and check them.
5112
5113          if Nkind (Last_Stm) = N_Label
5114            and then Exception_Junk (Last_Stm)
5115          then
5116             Stm := Last_Stm;
5117             loop
5118                Prev (Stm);
5119                exit when No (Stm);
5120                exit when Nkind (Stm) /= N_Block_Statement;
5121                exit when not Exception_Junk (Stm);
5122                Prev (Stm);
5123                exit when No (Stm);
5124                exit when Nkind (Stm) /= N_Label;
5125                exit when not Exception_Junk (Stm);
5126                Check_Statement_Sequence
5127                  (Statements (Handled_Statement_Sequence (Next (Stm))));
5128
5129                Prev (Stm);
5130                Last_Stm := Stm;
5131                exit when No (Stm);
5132                exit when Nkind (Stm) /= N_Goto_Statement;
5133                exit when not Exception_Junk (Stm);
5134             end loop;
5135          end if;
5136
5137          --  Don't count pragmas
5138
5139          while Nkind (Last_Stm) = N_Pragma
5140
5141          --  Don't count call to SS_Release (can happen after Raise_Exception)
5142
5143            or else
5144              (Nkind (Last_Stm) = N_Procedure_Call_Statement
5145                 and then
5146               Nkind (Name (Last_Stm)) = N_Identifier
5147                 and then
5148               Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
5149
5150          --  Don't count exception junk
5151
5152            or else
5153              (Nkind_In (Last_Stm, N_Goto_Statement,
5154                                    N_Label,
5155                                    N_Object_Declaration)
5156                 and then Exception_Junk (Last_Stm))
5157            or else Nkind (Last_Stm) in N_Push_xxx_Label
5158            or else Nkind (Last_Stm) in N_Pop_xxx_Label
5159          loop
5160             Prev (Last_Stm);
5161          end loop;
5162
5163          --  Here we have the "real" last statement
5164
5165          Kind := Nkind (Last_Stm);
5166
5167          --  Transfer of control, OK. Note that in the No_Return procedure
5168          --  case, we already diagnosed any explicit return statements, so
5169          --  we can treat them as OK in this context.
5170
5171          if Is_Transfer (Last_Stm) then
5172             return;
5173
5174          --  Check cases of explicit non-indirect procedure calls
5175
5176          elsif Kind = N_Procedure_Call_Statement
5177            and then Is_Entity_Name (Name (Last_Stm))
5178          then
5179             --  Check call to Raise_Exception procedure which is treated
5180             --  specially, as is a call to Reraise_Occurrence.
5181
5182             --  We suppress the warning in these cases since it is likely that
5183             --  the programmer really does not expect to deal with the case
5184             --  of Null_Occurrence, and thus would find a warning about a
5185             --  missing return curious, and raising Program_Error does not
5186             --  seem such a bad behavior if this does occur.
5187
5188             --  Note that in the Ada 2005 case for Raise_Exception, the actual
5189             --  behavior will be to raise Constraint_Error (see AI-329).
5190
5191             if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
5192                  or else
5193                Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
5194             then
5195                Raise_Exception_Call := True;
5196
5197                --  For Raise_Exception call, test first argument, if it is
5198                --  an attribute reference for a 'Identity call, then we know
5199                --  that the call cannot possibly return.
5200
5201                declare
5202                   Arg : constant Node_Id :=
5203                           Original_Node (First_Actual (Last_Stm));
5204                begin
5205                   if Nkind (Arg) = N_Attribute_Reference
5206                     and then Attribute_Name (Arg) = Name_Identity
5207                   then
5208                      return;
5209                   end if;
5210                end;
5211             end if;
5212
5213          --  If statement, need to look inside if there is an else and check
5214          --  each constituent statement sequence for proper termination.
5215
5216          elsif Kind = N_If_Statement
5217            and then Present (Else_Statements (Last_Stm))
5218          then
5219             Check_Statement_Sequence (Then_Statements (Last_Stm));
5220             Check_Statement_Sequence (Else_Statements (Last_Stm));
5221
5222             if Present (Elsif_Parts (Last_Stm)) then
5223                declare
5224                   Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
5225
5226                begin
5227                   while Present (Elsif_Part) loop
5228                      Check_Statement_Sequence (Then_Statements (Elsif_Part));
5229                      Next (Elsif_Part);
5230                   end loop;
5231                end;
5232             end if;
5233
5234             return;
5235
5236          --  Case statement, check each case for proper termination
5237
5238          elsif Kind = N_Case_Statement then
5239             declare
5240                Case_Alt : Node_Id;
5241             begin
5242                Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
5243                while Present (Case_Alt) loop
5244                   Check_Statement_Sequence (Statements (Case_Alt));
5245                   Next_Non_Pragma (Case_Alt);
5246                end loop;
5247             end;
5248
5249             return;
5250
5251          --  Block statement, check its handled sequence of statements
5252
5253          elsif Kind = N_Block_Statement then
5254             declare
5255                Err1 : Boolean;
5256
5257             begin
5258                Check_Returns
5259                  (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
5260
5261                if Err1 then
5262                   Err := True;
5263                end if;
5264
5265                return;
5266             end;
5267
5268          --  Loop statement. If there is an iteration scheme, we can definitely
5269          --  fall out of the loop. Similarly if there is an exit statement, we
5270          --  can fall out. In either case we need a following return.
5271
5272          elsif Kind = N_Loop_Statement then
5273             if Present (Iteration_Scheme (Last_Stm))
5274               or else Has_Exit (Entity (Identifier (Last_Stm)))
5275             then
5276                null;
5277
5278             --  A loop with no exit statement or iteration scheme is either
5279             --  an infinite loop, or it has some other exit (raise/return).
5280             --  In either case, no warning is required.
5281
5282             else
5283                return;
5284             end if;
5285
5286          --  Timed entry call, check entry call and delay alternatives
5287
5288          --  Note: in expanded code, the timed entry call has been converted
5289          --  to a set of expanded statements on which the check will work
5290          --  correctly in any case.
5291
5292          elsif Kind = N_Timed_Entry_Call then
5293             declare
5294                ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
5295                DCA : constant Node_Id := Delay_Alternative      (Last_Stm);
5296
5297             begin
5298                --  If statement sequence of entry call alternative is missing,
5299                --  then we can definitely fall through, and we post the error
5300                --  message on the entry call alternative itself.
5301
5302                if No (Statements (ECA)) then
5303                   Last_Stm := ECA;
5304
5305                --  If statement sequence of delay alternative is missing, then
5306                --  we can definitely fall through, and we post the error
5307                --  message on the delay alternative itself.
5308
5309                --  Note: if both ECA and DCA are missing the return, then we
5310                --  post only one message, should be enough to fix the bugs.
5311                --  If not we will get a message next time on the DCA when the
5312                --  ECA is fixed!
5313
5314                elsif No (Statements (DCA)) then
5315                   Last_Stm := DCA;
5316
5317                --  Else check both statement sequences
5318
5319                else
5320                   Check_Statement_Sequence (Statements (ECA));
5321                   Check_Statement_Sequence (Statements (DCA));
5322                   return;
5323                end if;
5324             end;
5325
5326          --  Conditional entry call, check entry call and else part
5327
5328          --  Note: in expanded code, the conditional entry call has been
5329          --  converted to a set of expanded statements on which the check
5330          --  will work correctly in any case.
5331
5332          elsif Kind = N_Conditional_Entry_Call then
5333             declare
5334                ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
5335
5336             begin
5337                --  If statement sequence of entry call alternative is missing,
5338                --  then we can definitely fall through, and we post the error
5339                --  message on the entry call alternative itself.
5340
5341                if No (Statements (ECA)) then
5342                   Last_Stm := ECA;
5343
5344                --  Else check statement sequence and else part
5345
5346                else
5347                   Check_Statement_Sequence (Statements (ECA));
5348                   Check_Statement_Sequence (Else_Statements (Last_Stm));
5349                   return;
5350                end if;
5351             end;
5352          end if;
5353
5354          --  If we fall through, issue appropriate message
5355
5356          if Mode = 'F' then
5357             if not Raise_Exception_Call then
5358                Error_Msg_N
5359                  ("?RETURN statement missing following this statement!",
5360                   Last_Stm);
5361                Error_Msg_N
5362                  ("\?Program_Error may be raised at run time!",
5363                   Last_Stm);
5364             end if;
5365
5366             --  Note: we set Err even though we have not issued a warning
5367             --  because we still have a case of a missing return. This is
5368             --  an extremely marginal case, probably will never be noticed
5369             --  but we might as well get it right.
5370
5371             Err := True;
5372
5373          --  Otherwise we have the case of a procedure marked No_Return
5374
5375          else
5376             if not Raise_Exception_Call then
5377                Error_Msg_N
5378                  ("?implied return after this statement " &
5379                   "will raise Program_Error",
5380                   Last_Stm);
5381                Error_Msg_NE
5382                  ("\?procedure & is marked as No_Return!",
5383                   Last_Stm, Proc);
5384             end if;
5385
5386             declare
5387                RE : constant Node_Id :=
5388                       Make_Raise_Program_Error (Sloc (Last_Stm),
5389                         Reason => PE_Implicit_Return);
5390             begin
5391                Insert_After (Last_Stm, RE);
5392                Analyze (RE);
5393             end;
5394          end if;
5395       end Check_Statement_Sequence;
5396
5397    --  Start of processing for Check_Returns
5398
5399    begin
5400       Err := False;
5401       Check_Statement_Sequence (Statements (HSS));
5402
5403       if Present (Exception_Handlers (HSS)) then
5404          Handler := First_Non_Pragma (Exception_Handlers (HSS));
5405          while Present (Handler) loop
5406             Check_Statement_Sequence (Statements (Handler));
5407             Next_Non_Pragma (Handler);
5408          end loop;
5409       end if;
5410    end Check_Returns;
5411
5412    ----------------------------
5413    -- Check_Subprogram_Order --
5414    ----------------------------
5415
5416    procedure Check_Subprogram_Order (N : Node_Id) is
5417
5418       function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
5419       --  This is used to check if S1 > S2 in the sense required by this
5420       --  test, for example nameab < namec, but name2 < name10.
5421
5422       -----------------------------
5423       -- Subprogram_Name_Greater --
5424       -----------------------------
5425
5426       function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
5427          L1, L2 : Positive;
5428          N1, N2 : Natural;
5429
5430       begin
5431          --  Remove trailing numeric parts
5432
5433          L1 := S1'Last;
5434          while S1 (L1) in '0' .. '9' loop
5435             L1 := L1 - 1;
5436          end loop;
5437
5438          L2 := S2'Last;
5439          while S2 (L2) in '0' .. '9' loop
5440             L2 := L2 - 1;
5441          end loop;
5442
5443          --  If non-numeric parts non-equal, that's decisive
5444
5445          if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
5446             return False;
5447
5448          elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
5449             return True;
5450
5451          --  If non-numeric parts equal, compare suffixed numeric parts. Note
5452          --  that a missing suffix is treated as numeric zero in this test.
5453
5454          else
5455             N1 := 0;
5456             while L1 < S1'Last loop
5457                L1 := L1 + 1;
5458                N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
5459             end loop;
5460
5461             N2 := 0;
5462             while L2 < S2'Last loop
5463                L2 := L2 + 1;
5464                N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
5465             end loop;
5466
5467             return N1 > N2;
5468          end if;
5469       end Subprogram_Name_Greater;
5470
5471    --  Start of processing for Check_Subprogram_Order
5472
5473    begin
5474       --  Check body in alpha order if this is option
5475
5476       if Style_Check
5477         and then Style_Check_Order_Subprograms
5478         and then Nkind (N) = N_Subprogram_Body
5479         and then Comes_From_Source (N)
5480         and then In_Extended_Main_Source_Unit (N)
5481       then
5482          declare
5483             LSN : String_Ptr
5484                     renames Scope_Stack.Table
5485                               (Scope_Stack.Last).Last_Subprogram_Name;
5486
5487             Body_Id : constant Entity_Id :=
5488                         Defining_Entity (Specification (N));
5489
5490          begin
5491             Get_Decoded_Name_String (Chars (Body_Id));
5492
5493             if LSN /= null then
5494                if Subprogram_Name_Greater
5495                     (LSN.all, Name_Buffer (1 .. Name_Len))
5496                then
5497                   Style.Subprogram_Not_In_Alpha_Order (Body_Id);
5498                end if;
5499
5500                Free (LSN);
5501             end if;
5502
5503             LSN := new String'(Name_Buffer (1 .. Name_Len));
5504          end;
5505       end if;
5506    end Check_Subprogram_Order;
5507
5508    ------------------------------
5509    -- Check_Subtype_Conformant --
5510    ------------------------------
5511
5512    procedure Check_Subtype_Conformant
5513      (New_Id                   : Entity_Id;
5514       Old_Id                   : Entity_Id;
5515       Err_Loc                  : Node_Id := Empty;
5516       Skip_Controlling_Formals : Boolean := False)
5517    is
5518       Result : Boolean;
5519       pragma Warnings (Off, Result);
5520    begin
5521       Check_Conformance
5522         (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
5523          Skip_Controlling_Formals => Skip_Controlling_Formals);
5524    end Check_Subtype_Conformant;
5525
5526    ---------------------------
5527    -- Check_Type_Conformant --
5528    ---------------------------
5529
5530    procedure Check_Type_Conformant
5531      (New_Id  : Entity_Id;
5532       Old_Id  : Entity_Id;
5533       Err_Loc : Node_Id := Empty)
5534    is
5535       Result : Boolean;
5536       pragma Warnings (Off, Result);
5537    begin
5538       Check_Conformance
5539         (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
5540    end Check_Type_Conformant;
5541
5542    ---------------------------
5543    -- Can_Override_Operator --
5544    ---------------------------
5545
5546    function Can_Override_Operator (Subp : Entity_Id) return Boolean is
5547       Typ : Entity_Id;
5548    begin
5549       if Nkind (Subp) /= N_Defining_Operator_Symbol then
5550          return False;
5551
5552       else
5553          Typ := Base_Type (Etype (First_Formal (Subp)));
5554
5555          return Operator_Matches_Spec (Subp, Subp)
5556            and then Scope (Subp) = Scope (Typ)
5557            and then not Is_Class_Wide_Type (Typ);
5558       end if;
5559    end Can_Override_Operator;
5560
5561    ----------------------
5562    -- Conforming_Types --
5563    ----------------------
5564
5565    function Conforming_Types
5566      (T1       : Entity_Id;
5567       T2       : Entity_Id;
5568       Ctype    : Conformance_Type;
5569       Get_Inst : Boolean := False) return Boolean
5570    is
5571       Type_1 : Entity_Id := T1;
5572       Type_2 : Entity_Id := T2;
5573       Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
5574
5575       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
5576       --  If neither T1 nor T2 are generic actual types, or if they are in
5577       --  different scopes (e.g. parent and child instances), then verify that
5578       --  the base types are equal. Otherwise T1 and T2 must be on the same
5579       --  subtype chain. The whole purpose of this procedure is to prevent
5580       --  spurious ambiguities in an instantiation that may arise if two
5581       --  distinct generic types are instantiated with the same actual.
5582
5583       function Find_Designated_Type (T : Entity_Id) return Entity_Id;
5584       --  An access parameter can designate an incomplete type. If the
5585       --  incomplete type is the limited view of a type from a limited_
5586       --  with_clause, check whether the non-limited view is available. If
5587       --  it is a (non-limited) incomplete type, get the full view.
5588
5589       function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
5590       --  Returns True if and only if either T1 denotes a limited view of T2
5591       --  or T2 denotes a limited view of T1. This can arise when the limited
5592       --  with view of a type is used in a subprogram declaration and the
5593       --  subprogram body is in the scope of a regular with clause for the
5594       --  same unit. In such a case, the two type entities can be considered
5595       --  identical for purposes of conformance checking.
5596
5597       ----------------------
5598       -- Base_Types_Match --
5599       ----------------------
5600
5601       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
5602       begin
5603          if T1 = T2 then
5604             return True;
5605
5606          elsif Base_Type (T1) = Base_Type (T2) then
5607
5608             --  The following is too permissive. A more precise test should
5609             --  check that the generic actual is an ancestor subtype of the
5610             --  other ???.
5611
5612             return not Is_Generic_Actual_Type (T1)
5613               or else not Is_Generic_Actual_Type (T2)
5614               or else Scope (T1) /= Scope (T2);
5615
5616          else
5617             return False;
5618          end if;
5619       end Base_Types_Match;
5620
5621       --------------------------
5622       -- Find_Designated_Type --
5623       --------------------------
5624
5625       function Find_Designated_Type (T : Entity_Id) return Entity_Id is
5626          Desig : Entity_Id;
5627
5628       begin
5629          Desig := Directly_Designated_Type (T);
5630
5631          if Ekind (Desig) = E_Incomplete_Type then
5632
5633             --  If regular incomplete type, get full view if available
5634
5635             if Present (Full_View (Desig)) then
5636                Desig := Full_View (Desig);
5637
5638             --  If limited view of a type, get non-limited view if available,
5639             --  and check again for a regular incomplete type.
5640
5641             elsif Present (Non_Limited_View (Desig)) then
5642                Desig := Get_Full_View (Non_Limited_View (Desig));
5643             end if;
5644          end if;
5645
5646          return Desig;
5647       end Find_Designated_Type;
5648
5649       -------------------------------
5650       -- Matches_Limited_With_View --
5651       -------------------------------
5652
5653       function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is
5654       begin
5655          --  In some cases a type imported through a limited_with clause, and
5656          --  its nonlimited view are both visible, for example in an anonymous
5657          --  access-to-class-wide type in a formal. Both entities designate the
5658          --  same type.
5659
5660          if From_With_Type (T1)
5661            and then T2 = Available_View (T1)
5662          then
5663             return True;
5664
5665          elsif From_With_Type (T2)
5666            and then T1 = Available_View (T2)
5667          then
5668             return True;
5669
5670          else
5671             return False;
5672          end if;
5673       end Matches_Limited_With_View;
5674
5675    --  Start of processing for Conforming_Types
5676
5677    begin
5678       --  The context is an instance association for a formal
5679       --  access-to-subprogram type; the formal parameter types require
5680       --  mapping because they may denote other formal parameters of the
5681       --  generic unit.
5682
5683       if Get_Inst then
5684          Type_1 := Get_Instance_Of (T1);
5685          Type_2 := Get_Instance_Of (T2);
5686       end if;
5687
5688       --  If one of the types is a view of the other introduced by a limited
5689       --  with clause, treat these as conforming for all purposes.
5690
5691       if Matches_Limited_With_View (T1, T2) then
5692          return True;
5693
5694       elsif Base_Types_Match (Type_1, Type_2) then
5695          return Ctype <= Mode_Conformant
5696            or else Subtypes_Statically_Match (Type_1, Type_2);
5697
5698       elsif Is_Incomplete_Or_Private_Type (Type_1)
5699         and then Present (Full_View (Type_1))
5700         and then Base_Types_Match (Full_View (Type_1), Type_2)
5701       then
5702          return Ctype <= Mode_Conformant
5703            or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
5704
5705       elsif Ekind (Type_2) = E_Incomplete_Type
5706         and then Present (Full_View (Type_2))
5707         and then Base_Types_Match (Type_1, Full_View (Type_2))
5708       then
5709          return Ctype <= Mode_Conformant
5710            or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
5711
5712       elsif Is_Private_Type (Type_2)
5713         and then In_Instance
5714         and then Present (Full_View (Type_2))
5715         and then Base_Types_Match (Type_1, Full_View (Type_2))
5716       then
5717          return Ctype <= Mode_Conformant
5718            or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
5719       end if;
5720
5721       --  Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
5722       --  treated recursively because they carry a signature.
5723
5724       Are_Anonymous_Access_To_Subprogram_Types :=
5725         Ekind (Type_1) = Ekind (Type_2)
5726           and then
5727             (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
5728              or else
5729                Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
5730
5731       --  Test anonymous access type case. For this case, static subtype
5732       --  matching is required for mode conformance (RM 6.3.1(15)). We check
5733       --  the base types because we may have built internal subtype entities
5734       --  to handle null-excluding types (see Process_Formals).
5735
5736       if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
5737             and then
5738           Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
5739         or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
5740       then
5741          declare
5742             Desig_1 : Entity_Id;
5743             Desig_2 : Entity_Id;
5744
5745          begin
5746             --  In Ada2005, access constant indicators must match for
5747             --  subtype conformance.
5748
5749             if Ada_Version >= Ada_2005
5750               and then Ctype >= Subtype_Conformant
5751               and then
5752                 Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
5753             then
5754                return False;
5755             end if;
5756
5757             Desig_1 := Find_Designated_Type (Type_1);
5758             Desig_2 := Find_Designated_Type (Type_2);
5759
5760             --  If the context is an instance association for a formal
5761             --  access-to-subprogram type; formal access parameter designated
5762             --  types require mapping because they may denote other formal
5763             --  parameters of the generic unit.
5764
5765             if Get_Inst then
5766                Desig_1 := Get_Instance_Of (Desig_1);
5767                Desig_2 := Get_Instance_Of (Desig_2);
5768             end if;
5769
5770             --  It is possible for a Class_Wide_Type to be introduced for an
5771             --  incomplete type, in which case there is a separate class_ wide
5772             --  type for the full view. The types conform if their Etypes
5773             --  conform, i.e. one may be the full view of the other. This can
5774             --  only happen in the context of an access parameter, other uses
5775             --  of an incomplete Class_Wide_Type are illegal.
5776
5777             if Is_Class_Wide_Type (Desig_1)
5778                  and then
5779                Is_Class_Wide_Type (Desig_2)
5780             then
5781                return
5782                  Conforming_Types
5783                    (Etype (Base_Type (Desig_1)),
5784                     Etype (Base_Type (Desig_2)), Ctype);
5785
5786             elsif Are_Anonymous_Access_To_Subprogram_Types then
5787                if Ada_Version < Ada_2005 then
5788                   return Ctype = Type_Conformant
5789                     or else
5790                       Subtypes_Statically_Match (Desig_1, Desig_2);
5791
5792                --  We must check the conformance of the signatures themselves
5793
5794                else
5795                   declare
5796                      Conformant : Boolean;
5797                   begin
5798                      Check_Conformance
5799                        (Desig_1, Desig_2, Ctype, False, Conformant);
5800                      return Conformant;
5801                   end;
5802                end if;
5803
5804             else
5805                return Base_Type (Desig_1) = Base_Type (Desig_2)
5806                 and then (Ctype = Type_Conformant
5807                             or else
5808                           Subtypes_Statically_Match (Desig_1, Desig_2));
5809             end if;
5810          end;
5811
5812       --  Otherwise definitely no match
5813
5814       else
5815          if ((Ekind (Type_1) = E_Anonymous_Access_Type
5816                and then Is_Access_Type (Type_2))
5817             or else (Ekind (Type_2) = E_Anonymous_Access_Type
5818                        and then Is_Access_Type (Type_1)))
5819            and then
5820              Conforming_Types
5821                (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
5822          then
5823             May_Hide_Profile := True;
5824          end if;
5825
5826          return False;
5827       end if;
5828    end Conforming_Types;
5829
5830    --------------------------
5831    -- Create_Extra_Formals --
5832    --------------------------
5833
5834    procedure Create_Extra_Formals (E : Entity_Id) is
5835       Formal      : Entity_Id;
5836       First_Extra : Entity_Id := Empty;
5837       Last_Extra  : Entity_Id;
5838       Formal_Type : Entity_Id;
5839       P_Formal    : Entity_Id := Empty;
5840
5841       function Add_Extra_Formal
5842         (Assoc_Entity : Entity_Id;
5843          Typ          : Entity_Id;
5844          Scope        : Entity_Id;
5845          Suffix       : String) return Entity_Id;
5846       --  Add an extra formal to the current list of formals and extra formals.
5847       --  The extra formal is added to the end of the list of extra formals,
5848       --  and also returned as the result. These formals are always of mode IN.
5849       --  The new formal has the type Typ, is declared in Scope, and its name
5850       --  is given by a concatenation of the name of Assoc_Entity and Suffix.
5851       --  The following suffixes are currently used. They should not be changed
5852       --  without coordinating with CodePeer, which makes use of these to
5853       --  provide better messages.
5854
5855       --  O denotes the Constrained bit.
5856       --  L denotes the accessibility level.
5857       --  BIP_xxx denotes an extra formal for a build-in-place function. See
5858       --  the full list in exp_ch6.BIP_Formal_Kind.
5859
5860       ----------------------
5861       -- Add_Extra_Formal --
5862       ----------------------
5863
5864       function Add_Extra_Formal
5865         (Assoc_Entity : Entity_Id;
5866          Typ          : Entity_Id;
5867          Scope        : Entity_Id;
5868          Suffix       : String) return Entity_Id
5869       is
5870          EF : constant Entity_Id :=
5871                 Make_Defining_Identifier (Sloc (Assoc_Entity),
5872                   Chars  => New_External_Name (Chars (Assoc_Entity),
5873                                                Suffix => Suffix));
5874
5875       begin
5876          --  A little optimization. Never generate an extra formal for the
5877          --  _init operand of an initialization procedure, since it could
5878          --  never be used.
5879
5880          if Chars (Formal) = Name_uInit then
5881             return Empty;
5882          end if;
5883
5884          Set_Ekind           (EF, E_In_Parameter);
5885          Set_Actual_Subtype  (EF, Typ);
5886          Set_Etype           (EF, Typ);
5887          Set_Scope           (EF, Scope);
5888          Set_Mechanism       (EF, Default_Mechanism);
5889          Set_Formal_Validity (EF);
5890
5891          if No (First_Extra) then
5892             First_Extra := EF;
5893             Set_Extra_Formals (Scope, First_Extra);
5894          end if;
5895
5896          if Present (Last_Extra) then
5897             Set_Extra_Formal (Last_Extra, EF);
5898          end if;
5899
5900          Last_Extra := EF;
5901
5902          return EF;
5903       end Add_Extra_Formal;
5904
5905    --  Start of processing for Create_Extra_Formals
5906
5907    begin
5908       --  We never generate extra formals if expansion is not active
5909       --  because we don't need them unless we are generating code.
5910
5911       if not Expander_Active then
5912          return;
5913       end if;
5914
5915       --  If this is a derived subprogram then the subtypes of the parent
5916       --  subprogram's formal parameters will be used to determine the need
5917       --  for extra formals.
5918
5919       if Is_Overloadable (E) and then Present (Alias (E)) then
5920          P_Formal := First_Formal (Alias (E));
5921       end if;
5922
5923       Last_Extra := Empty;
5924       Formal := First_Formal (E);
5925       while Present (Formal) loop
5926          Last_Extra := Formal;
5927          Next_Formal (Formal);
5928       end loop;
5929
5930       --  If Extra_formals were already created, don't do it again. This
5931       --  situation may arise for subprogram types created as part of
5932       --  dispatching calls (see Expand_Dispatching_Call)
5933
5934       if Present (Last_Extra) and then
5935         Present (Extra_Formal (Last_Extra))
5936       then
5937          return;
5938       end if;
5939
5940       --  If the subprogram is a predefined dispatching subprogram then don't
5941       --  generate any extra constrained or accessibility level formals. In
5942       --  general we suppress these for internal subprograms (by not calling
5943       --  Freeze_Subprogram and Create_Extra_Formals at all), but internally
5944       --  generated stream attributes do get passed through because extra
5945       --  build-in-place formals are needed in some cases (limited 'Input).
5946
5947       if Is_Predefined_Internal_Operation (E) then
5948          goto Test_For_BIP_Extras;
5949       end if;
5950
5951       Formal := First_Formal (E);
5952       while Present (Formal) loop
5953
5954          --  Create extra formal for supporting the attribute 'Constrained.
5955          --  The case of a private type view without discriminants also
5956          --  requires the extra formal if the underlying type has defaulted
5957          --  discriminants.
5958
5959          if Ekind (Formal) /= E_In_Parameter then
5960             if Present (P_Formal) then
5961                Formal_Type := Etype (P_Formal);
5962             else
5963                Formal_Type := Etype (Formal);
5964             end if;
5965
5966             --  Do not produce extra formals for Unchecked_Union parameters.
5967             --  Jump directly to the end of the loop.
5968
5969             if Is_Unchecked_Union (Base_Type (Formal_Type)) then
5970                goto Skip_Extra_Formal_Generation;
5971             end if;
5972
5973             if not Has_Discriminants (Formal_Type)
5974               and then Ekind (Formal_Type) in Private_Kind
5975               and then Present (Underlying_Type (Formal_Type))
5976             then
5977                Formal_Type := Underlying_Type (Formal_Type);
5978             end if;
5979
5980             --  Suppress the extra formal if formal's subtype is constrained or
5981             --  indefinite, or we're compiling for Ada 2012 and the underlying
5982             --  type is tagged and limited. In Ada 2012, a limited tagged type
5983             --  can have defaulted discriminants, but 'Constrained is required
5984             --  to return True, so the formal is never needed (see AI05-0214).
5985             --  Note that this ensures consistency of calling sequences for
5986             --  dispatching operations when some types in a class have defaults
5987             --  on discriminants and others do not (and requiring the extra
5988             --  formal would introduce distributed overhead).
5989
5990             if Has_Discriminants (Formal_Type)
5991               and then not Is_Constrained (Formal_Type)
5992               and then not Is_Indefinite_Subtype (Formal_Type)
5993               and then (Ada_Version < Ada_2012
5994                          or else
5995                            not (Is_Tagged_Type (Underlying_Type (Formal_Type))
5996                                  and then Is_Limited_Type (Formal_Type)))
5997             then
5998                Set_Extra_Constrained
5999                  (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O"));
6000             end if;
6001          end if;
6002
6003          --  Create extra formal for supporting accessibility checking. This
6004          --  is done for both anonymous access formals and formals of named
6005          --  access types that are marked as controlling formals. The latter
6006          --  case can occur when Expand_Dispatching_Call creates a subprogram
6007          --  type and substitutes the types of access-to-class-wide actuals
6008          --  for the anonymous access-to-specific-type of controlling formals.
6009          --  Base_Type is applied because in cases where there is a null
6010          --  exclusion the formal may have an access subtype.
6011
6012          --  This is suppressed if we specifically suppress accessibility
6013          --  checks at the package level for either the subprogram, or the
6014          --  package in which it resides. However, we do not suppress it
6015          --  simply if the scope has accessibility checks suppressed, since
6016          --  this could cause trouble when clients are compiled with a
6017          --  different suppression setting. The explicit checks at the
6018          --  package level are safe from this point of view.
6019
6020          if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
6021               or else (Is_Controlling_Formal (Formal)
6022                         and then Is_Access_Type (Base_Type (Etype (Formal)))))
6023            and then not
6024              (Explicit_Suppress (E, Accessibility_Check)
6025                or else
6026               Explicit_Suppress (Scope (E), Accessibility_Check))
6027            and then
6028              (No (P_Formal)
6029                or else Present (Extra_Accessibility (P_Formal)))
6030          then
6031             Set_Extra_Accessibility
6032               (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L"));
6033          end if;
6034
6035          --  This label is required when skipping extra formal generation for
6036          --  Unchecked_Union parameters.
6037
6038          <<Skip_Extra_Formal_Generation>>
6039
6040          if Present (P_Formal) then
6041             Next_Formal (P_Formal);
6042          end if;
6043
6044          Next_Formal (Formal);
6045       end loop;
6046
6047       <<Test_For_BIP_Extras>>
6048
6049       --  Ada 2005 (AI-318-02): In the case of build-in-place functions, add
6050       --  appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
6051
6052       if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then
6053          declare
6054             Result_Subt : constant Entity_Id := Etype (E);
6055
6056             Discard : Entity_Id;
6057             pragma Warnings (Off, Discard);
6058
6059          begin
6060             --  In the case of functions with unconstrained result subtypes,
6061             --  add a 4-state formal indicating whether the return object is
6062             --  allocated by the caller (1), or should be allocated by the
6063             --  callee on the secondary stack (2), in the global heap (3), or
6064             --  in a user-defined storage pool (4). For the moment we just use
6065             --  Natural for the type of this formal. Note that this formal
6066             --  isn't usually needed in the case where the result subtype is
6067             --  constrained, but it is needed when the function has a tagged
6068             --  result, because generally such functions can be called in a
6069             --  dispatching context and such calls must be handled like calls
6070             --  to a class-wide function.
6071
6072             if not Is_Constrained (Underlying_Type (Result_Subt))
6073               or else Is_Tagged_Type (Underlying_Type (Result_Subt))
6074             then
6075                Discard :=
6076                  Add_Extra_Formal
6077                    (E, Standard_Natural,
6078                     E, BIP_Formal_Suffix (BIP_Alloc_Form));
6079             end if;
6080
6081             --  In the case of functions whose result type needs finalization,
6082             --  add an extra formal of type Ada.Finalization.Heap_Management.
6083             --  Finalization_Collection_Ptr.
6084
6085             if Needs_BIP_Collection (E) then
6086                Discard :=
6087                  Add_Extra_Formal
6088                    (E, RTE (RE_Finalization_Collection_Ptr),
6089                     E, BIP_Formal_Suffix (BIP_Collection));
6090             end if;
6091
6092             --  If the result type contains tasks, we have two extra formals:
6093             --  the master of the tasks to be created, and the caller's
6094             --  activation chain.
6095
6096             if Has_Task (Result_Subt) then
6097                Discard :=
6098                  Add_Extra_Formal
6099                    (E, RTE (RE_Master_Id),
6100                     E, BIP_Formal_Suffix (BIP_Master));
6101                Discard :=
6102                  Add_Extra_Formal
6103                    (E, RTE (RE_Activation_Chain_Access),
6104                     E, BIP_Formal_Suffix (BIP_Activation_Chain));
6105             end if;
6106
6107             --  All build-in-place functions get an extra formal that will be
6108             --  passed the address of the return object within the caller.
6109
6110             declare
6111                Formal_Type : constant Entity_Id :=
6112                                Create_Itype
6113                                  (E_Anonymous_Access_Type, E,
6114                                   Scope_Id => Scope (E));
6115             begin
6116                Set_Directly_Designated_Type (Formal_Type, Result_Subt);
6117                Set_Etype (Formal_Type, Formal_Type);
6118                Set_Depends_On_Private
6119                  (Formal_Type, Has_Private_Component (Formal_Type));
6120                Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
6121                Set_Is_Access_Constant (Formal_Type, False);
6122
6123                --  Ada 2005 (AI-50217): Propagate the attribute that indicates
6124                --  the designated type comes from the limited view (for
6125                --  back-end purposes).
6126
6127                Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
6128
6129                Layout_Type (Formal_Type);
6130
6131                Discard :=
6132                  Add_Extra_Formal
6133                    (E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access));
6134             end;
6135          end;
6136       end if;
6137    end Create_Extra_Formals;
6138
6139    -----------------------------
6140    -- Enter_Overloaded_Entity --
6141    -----------------------------
6142
6143    procedure Enter_Overloaded_Entity (S : Entity_Id) is
6144       E   : Entity_Id := Current_Entity_In_Scope (S);
6145       C_E : Entity_Id := Current_Entity (S);
6146
6147    begin
6148       if Present (E) then
6149          Set_Has_Homonym (E);
6150          Set_Has_Homonym (S);
6151       end if;
6152
6153       Set_Is_Immediately_Visible (S);
6154       Set_Scope (S, Current_Scope);
6155
6156       --  Chain new entity if front of homonym in current scope, so that
6157       --  homonyms are contiguous.
6158
6159       if Present (E)
6160         and then E /= C_E
6161       then
6162          while Homonym (C_E) /= E loop
6163             C_E := Homonym (C_E);
6164          end loop;
6165
6166          Set_Homonym (C_E, S);
6167
6168       else
6169          E := C_E;
6170          Set_Current_Entity (S);
6171       end if;
6172
6173       Set_Homonym (S, E);
6174
6175       Append_Entity (S, Current_Scope);
6176       Set_Public_Status (S);
6177
6178       if Debug_Flag_E then
6179          Write_Str ("New overloaded entity chain: ");
6180          Write_Name (Chars (S));
6181
6182          E := S;
6183          while Present (E) loop
6184             Write_Str (" "); Write_Int (Int (E));
6185             E := Homonym (E);
6186          end loop;
6187
6188          Write_Eol;
6189       end if;
6190
6191       --  Generate warning for hiding
6192
6193       if Warn_On_Hiding
6194         and then Comes_From_Source (S)
6195         and then In_Extended_Main_Source_Unit (S)
6196       then
6197          E := S;
6198          loop
6199             E := Homonym (E);
6200             exit when No (E);
6201
6202             --  Warn unless genuine overloading. Do not emit warning on
6203             --  hiding predefined operators in Standard (these are either an
6204             --  (artifact of our implicit declarations, or simple noise) but
6205             --  keep warning on a operator defined on a local subtype, because
6206             --  of the real danger that different operators may be applied in
6207             --  various parts of the program.
6208
6209             --  Note that if E and S have the same scope, there is never any
6210             --  hiding. Either the two conflict, and the program is illegal,
6211             --  or S is overriding an implicit inherited subprogram.
6212
6213             if Scope (E) /= Scope (S)
6214                   and then (not Is_Overloadable (E)
6215                              or else Subtype_Conformant (E, S))
6216                   and then (Is_Immediately_Visible (E)
6217                               or else
6218                             Is_Potentially_Use_Visible (S))
6219             then
6220                if Scope (E) /= Standard_Standard then
6221                   Error_Msg_Sloc := Sloc (E);
6222                   Error_Msg_N ("declaration of & hides one#?", S);
6223
6224                elsif Nkind (S) = N_Defining_Operator_Symbol
6225                  and then
6226                    Scope (Base_Type (Etype (First_Formal (S)))) /= Scope (S)
6227                then
6228                   Error_Msg_N
6229                     ("declaration of & hides predefined operator?", S);
6230                end if;
6231             end if;
6232          end loop;
6233       end if;
6234    end Enter_Overloaded_Entity;
6235
6236    -----------------------------
6237    -- Check_Untagged_Equality --
6238    -----------------------------
6239
6240    procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
6241       Typ      : constant Entity_Id := Etype (First_Formal (Eq_Op));
6242       Decl     : constant Node_Id   := Unit_Declaration_Node (Eq_Op);
6243       Obj_Decl : Node_Id;
6244
6245    begin
6246       if Nkind (Decl) = N_Subprogram_Declaration
6247         and then Is_Record_Type (Typ)
6248         and then not Is_Tagged_Type (Typ)
6249       then
6250          --  If the type is not declared in a package, or if we are in the
6251          --  body of the package or in some other scope, the new operation is
6252          --  not primitive, and therefore legal, though suspicious. If the
6253          --  type is a generic actual (sub)type, the operation is not primitive
6254          --  either because the base type is declared elsewhere.
6255
6256          if Is_Frozen (Typ) then
6257             if Ekind (Scope (Typ)) /= E_Package
6258               or else Scope (Typ) /= Current_Scope
6259             then
6260                null;
6261
6262             elsif Is_Generic_Actual_Type (Typ) then
6263                null;
6264
6265             elsif In_Package_Body (Scope (Typ)) then
6266                Error_Msg_NE
6267                  ("equality operator must be declared "
6268                    & "before type& is frozen", Eq_Op, Typ);
6269                Error_Msg_N
6270                  ("\move declaration to package spec", Eq_Op);
6271
6272             else
6273                Error_Msg_NE
6274                  ("equality operator must be declared "
6275                    & "before type& is frozen", Eq_Op, Typ);
6276
6277                Obj_Decl := Next (Parent (Typ));
6278                while Present (Obj_Decl)
6279                  and then Obj_Decl /= Decl
6280                loop
6281                   if Nkind (Obj_Decl) = N_Object_Declaration
6282                     and then Etype (Defining_Identifier (Obj_Decl)) = Typ
6283                   then
6284                      Error_Msg_NE ("type& is frozen by declaration?",
6285                         Obj_Decl, Typ);
6286                      Error_Msg_N
6287                        ("\an equality operator cannot be declared after this "
6288                          & "point (RM 4.5.2 (9.8)) (Ada 2012))?", Obj_Decl);
6289                      exit;
6290                   end if;
6291
6292                   Next (Obj_Decl);
6293                end loop;
6294             end if;
6295
6296          elsif not In_Same_List (Parent (Typ), Decl)
6297            and then not Is_Limited_Type (Typ)
6298          then
6299
6300             --  This makes it illegal to have a primitive equality declared in
6301             --  the private part if the type is visible.
6302
6303             Error_Msg_N ("equality operator appears too late", Eq_Op);
6304          end if;
6305       end if;
6306    end Check_Untagged_Equality;
6307
6308    -----------------------------
6309    -- Find_Corresponding_Spec --
6310    -----------------------------
6311
6312    function Find_Corresponding_Spec
6313      (N          : Node_Id;
6314       Post_Error : Boolean := True) return Entity_Id
6315    is
6316       Spec       : constant Node_Id   := Specification (N);
6317       Designator : constant Entity_Id := Defining_Entity (Spec);
6318
6319       E : Entity_Id;
6320
6321    begin
6322       E := Current_Entity (Designator);
6323       while Present (E) loop
6324
6325          --  We are looking for a matching spec. It must have the same scope,
6326          --  and the same name, and either be type conformant, or be the case
6327          --  of a library procedure spec and its body (which belong to one
6328          --  another regardless of whether they are type conformant or not).
6329
6330          if Scope (E) = Current_Scope then
6331             if Current_Scope = Standard_Standard
6332               or else (Ekind (E) = Ekind (Designator)
6333                          and then Type_Conformant (E, Designator))
6334             then
6335                --  Within an instantiation, we know that spec and body are
6336                --  subtype conformant, because they were subtype conformant
6337                --  in the generic. We choose the subtype-conformant entity
6338                --  here as well, to resolve spurious ambiguities in the
6339                --  instance that were not present in the generic (i.e. when
6340                --  two different types are given the same actual). If we are
6341                --  looking for a spec to match a body, full conformance is
6342                --  expected.
6343
6344                if In_Instance then
6345                   Set_Convention (Designator, Convention (E));
6346
6347                   --  Skip past subprogram bodies and subprogram renamings that
6348                   --  may appear to have a matching spec, but that aren't fully
6349                   --  conformant with it. That can occur in cases where an
6350                   --  actual type causes unrelated homographs in the instance.
6351
6352                   if Nkind_In (N, N_Subprogram_Body,
6353                                   N_Subprogram_Renaming_Declaration)
6354                     and then Present (Homonym (E))
6355                     and then not Fully_Conformant (Designator, E)
6356                   then
6357                      goto Next_Entity;
6358
6359                   elsif not Subtype_Conformant (Designator, E) then
6360                      goto Next_Entity;
6361                   end if;
6362                end if;
6363
6364                if not Has_Completion (E) then
6365                   if Nkind (N) /= N_Subprogram_Body_Stub then
6366                      Set_Corresponding_Spec (N, E);
6367                   end if;
6368
6369                   Set_Has_Completion (E);
6370                   return E;
6371
6372                elsif Nkind (Parent (N)) = N_Subunit then
6373
6374                   --  If this is the proper body of a subunit, the completion
6375                   --  flag is set when analyzing the stub.
6376
6377                   return E;
6378
6379                --  If E is an internal function with a controlling result
6380                --  that was created for an operation inherited by a null
6381                --  extension, it may be overridden by a body without a previous
6382                --  spec (one more reason why these should be shunned). In that
6383                --  case remove the generated body if present, because the
6384                --  current one is the explicit overriding.
6385
6386                elsif Ekind (E) = E_Function
6387                  and then Ada_Version >= Ada_2005
6388                  and then not Comes_From_Source (E)
6389                  and then Has_Controlling_Result (E)
6390                  and then Is_Null_Extension (Etype (E))
6391                  and then Comes_From_Source (Spec)
6392                then
6393                   Set_Has_Completion (E, False);
6394
6395                   if Expander_Active
6396                     and then Nkind (Parent (E)) = N_Function_Specification
6397                   then
6398                      Remove
6399                        (Unit_Declaration_Node
6400                           (Corresponding_Body (Unit_Declaration_Node (E))));
6401
6402                      return E;
6403
6404                   --  If expansion is disabled, or if the wrapper function has
6405                   --  not been generated yet, this a late body overriding an
6406                   --  inherited operation, or it is an overriding by some other
6407                   --  declaration before the controlling result is frozen. In
6408                   --  either case this is a declaration of a new entity.
6409
6410                   else
6411                      return Empty;
6412                   end if;
6413
6414                --  If the body already exists, then this is an error unless
6415                --  the previous declaration is the implicit declaration of a
6416                --  derived subprogram. It is also legal for an instance to
6417                --  contain type conformant overloadable declarations (but the
6418                --  generic declaration may not), per 8.3(26/2).
6419
6420                elsif No (Alias (E))
6421                  and then not Is_Intrinsic_Subprogram (E)
6422                  and then not In_Instance
6423                  and then Post_Error
6424                then
6425                   Error_Msg_Sloc := Sloc (E);
6426
6427                   if Is_Imported (E) then
6428                      Error_Msg_NE
6429                       ("body not allowed for imported subprogram & declared#",
6430                         N, E);
6431                   else
6432                      Error_Msg_NE ("duplicate body for & declared#", N, E);
6433                   end if;
6434                end if;
6435
6436             --  Child units cannot be overloaded, so a conformance mismatch
6437             --  between body and a previous spec is an error.
6438
6439             elsif Is_Child_Unit (E)
6440               and then
6441                 Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
6442               and then
6443                 Nkind (Parent (Unit_Declaration_Node (Designator))) =
6444                   N_Compilation_Unit
6445               and then Post_Error
6446             then
6447                Error_Msg_N
6448                  ("body of child unit does not match previous declaration", N);
6449             end if;
6450          end if;
6451
6452          <<Next_Entity>>
6453             E := Homonym (E);
6454       end loop;
6455
6456       --  On exit, we know that no previous declaration of subprogram exists
6457
6458       return Empty;
6459    end Find_Corresponding_Spec;
6460
6461    ----------------------
6462    -- Fully_Conformant --
6463    ----------------------
6464
6465    function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
6466       Result : Boolean;
6467    begin
6468       Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
6469       return Result;
6470    end Fully_Conformant;
6471
6472    ----------------------------------
6473    -- Fully_Conformant_Expressions --
6474    ----------------------------------
6475
6476    function Fully_Conformant_Expressions
6477      (Given_E1 : Node_Id;
6478       Given_E2 : Node_Id) return Boolean
6479    is
6480       E1 : constant Node_Id := Original_Node (Given_E1);
6481       E2 : constant Node_Id := Original_Node (Given_E2);
6482       --  We always test conformance on original nodes, since it is possible
6483       --  for analysis and/or expansion to make things look as though they
6484       --  conform when they do not, e.g. by converting 1+2 into 3.
6485
6486       function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
6487         renames Fully_Conformant_Expressions;
6488
6489       function FCL (L1, L2 : List_Id) return Boolean;
6490       --  Compare elements of two lists for conformance. Elements have to
6491       --  be conformant, and actuals inserted as default parameters do not
6492       --  match explicit actuals with the same value.
6493
6494       function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
6495       --  Compare an operator node with a function call
6496
6497       ---------
6498       -- FCL --
6499       ---------
6500
6501       function FCL (L1, L2 : List_Id) return Boolean is
6502          N1, N2 : Node_Id;
6503
6504       begin
6505          if L1 = No_List then
6506             N1 := Empty;
6507          else
6508             N1 := First (L1);
6509          end if;
6510
6511          if L2 = No_List then
6512             N2 := Empty;
6513          else
6514             N2 := First (L2);
6515          end if;
6516
6517          --  Compare two lists, skipping rewrite insertions (we want to
6518          --  compare the original trees, not the expanded versions!)
6519
6520          loop
6521             if Is_Rewrite_Insertion (N1) then
6522                Next (N1);
6523             elsif Is_Rewrite_Insertion (N2) then
6524                Next (N2);
6525             elsif No (N1) then
6526                return No (N2);
6527             elsif No (N2) then
6528                return False;
6529             elsif not FCE (N1, N2) then
6530                return False;
6531             else
6532                Next (N1);
6533                Next (N2);
6534             end if;
6535          end loop;
6536       end FCL;
6537
6538       ---------
6539       -- FCO --
6540       ---------
6541
6542       function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
6543          Actuals : constant List_Id := Parameter_Associations (Call_Node);
6544          Act     : Node_Id;
6545
6546       begin
6547          if No (Actuals)
6548             or else Entity (Op_Node) /= Entity (Name (Call_Node))
6549          then
6550             return False;
6551
6552          else
6553             Act := First (Actuals);
6554
6555             if Nkind (Op_Node) in N_Binary_Op then
6556                if not FCE (Left_Opnd (Op_Node), Act) then
6557                   return False;
6558                end if;
6559
6560                Next (Act);
6561             end if;
6562
6563             return Present (Act)
6564               and then FCE (Right_Opnd (Op_Node), Act)
6565               and then No (Next (Act));
6566          end if;
6567       end FCO;
6568
6569    --  Start of processing for Fully_Conformant_Expressions
6570
6571    begin
6572       --  Non-conformant if paren count does not match. Note: if some idiot
6573       --  complains that we don't do this right for more than 3 levels of
6574       --  parentheses, they will be treated with the respect they deserve!
6575
6576       if Paren_Count (E1) /= Paren_Count (E2) then
6577          return False;
6578
6579       --  If same entities are referenced, then they are conformant even if
6580       --  they have different forms (RM 8.3.1(19-20)).
6581
6582       elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
6583          if Present (Entity (E1)) then
6584             return Entity (E1) = Entity (E2)
6585               or else (Chars (Entity (E1)) = Chars (Entity (E2))
6586                         and then Ekind (Entity (E1)) = E_Discriminant
6587                         and then Ekind (Entity (E2)) = E_In_Parameter);
6588
6589          elsif Nkind (E1) = N_Expanded_Name
6590            and then Nkind (E2) = N_Expanded_Name
6591            and then Nkind (Selector_Name (E1)) = N_Character_Literal
6592            and then Nkind (Selector_Name (E2)) = N_Character_Literal
6593          then
6594             return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
6595
6596          else
6597             --  Identifiers in component associations don't always have
6598             --  entities, but their names must conform.
6599
6600             return Nkind  (E1) = N_Identifier
6601               and then Nkind (E2) = N_Identifier
6602               and then Chars (E1) = Chars (E2);
6603          end if;
6604
6605       elsif Nkind (E1) = N_Character_Literal
6606         and then Nkind (E2) = N_Expanded_Name
6607       then
6608          return Nkind (Selector_Name (E2)) = N_Character_Literal
6609            and then Chars (E1) = Chars (Selector_Name (E2));
6610
6611       elsif Nkind (E2) = N_Character_Literal
6612         and then Nkind (E1) = N_Expanded_Name
6613       then
6614          return Nkind (Selector_Name (E1)) = N_Character_Literal
6615            and then Chars (E2) = Chars (Selector_Name (E1));
6616
6617       elsif Nkind (E1) in N_Op
6618         and then Nkind (E2) = N_Function_Call
6619       then
6620          return FCO (E1, E2);
6621
6622       elsif Nkind (E2) in N_Op
6623         and then Nkind (E1) = N_Function_Call
6624       then
6625          return FCO (E2, E1);
6626
6627       --  Otherwise we must have the same syntactic entity
6628
6629       elsif Nkind (E1) /= Nkind (E2) then
6630          return False;
6631
6632       --  At this point, we specialize by node type
6633
6634       else
6635          case Nkind (E1) is
6636
6637             when N_Aggregate =>
6638                return
6639                  FCL (Expressions (E1), Expressions (E2))
6640                    and then
6641                  FCL (Component_Associations (E1),
6642                       Component_Associations (E2));
6643
6644             when N_Allocator =>
6645                if Nkind (Expression (E1)) = N_Qualified_Expression
6646                     or else
6647                   Nkind (Expression (E2)) = N_Qualified_Expression
6648                then
6649                   return FCE (Expression (E1), Expression (E2));
6650
6651                --  Check that the subtype marks and any constraints
6652                --  are conformant
6653
6654                else
6655                   declare
6656                      Indic1 : constant Node_Id := Expression (E1);
6657                      Indic2 : constant Node_Id := Expression (E2);
6658                      Elt1   : Node_Id;
6659                      Elt2   : Node_Id;
6660
6661                   begin
6662                      if Nkind (Indic1) /= N_Subtype_Indication then
6663                         return
6664                           Nkind (Indic2) /= N_Subtype_Indication
6665                             and then Entity (Indic1) = Entity (Indic2);
6666
6667                      elsif Nkind (Indic2) /= N_Subtype_Indication then
6668                         return
6669                           Nkind (Indic1) /= N_Subtype_Indication
6670                             and then Entity (Indic1) = Entity (Indic2);
6671
6672                      else
6673                         if Entity (Subtype_Mark (Indic1)) /=
6674                           Entity (Subtype_Mark (Indic2))
6675                         then
6676                            return False;
6677                         end if;
6678
6679                         Elt1 := First (Constraints (Constraint (Indic1)));
6680                         Elt2 := First (Constraints (Constraint (Indic2)));
6681                         while Present (Elt1) and then Present (Elt2) loop
6682                            if not FCE (Elt1, Elt2) then
6683                               return False;
6684                            end if;
6685
6686                            Next (Elt1);
6687                            Next (Elt2);
6688                         end loop;
6689
6690                         return True;
6691                      end if;
6692                   end;
6693                end if;
6694
6695             when N_Attribute_Reference =>
6696                return
6697                  Attribute_Name (E1) = Attribute_Name (E2)
6698                    and then FCL (Expressions (E1), Expressions (E2));
6699
6700             when N_Binary_Op =>
6701                return
6702                  Entity (E1) = Entity (E2)
6703                    and then FCE (Left_Opnd  (E1), Left_Opnd  (E2))
6704                    and then FCE (Right_Opnd (E1), Right_Opnd (E2));
6705
6706             when N_Short_Circuit | N_Membership_Test =>
6707                return
6708                  FCE (Left_Opnd  (E1), Left_Opnd  (E2))
6709                    and then
6710                  FCE (Right_Opnd (E1), Right_Opnd (E2));
6711
6712             when N_Case_Expression =>
6713                declare
6714                   Alt1 : Node_Id;
6715                   Alt2 : Node_Id;
6716
6717                begin
6718                   if not FCE (Expression (E1), Expression (E2)) then
6719                      return False;
6720
6721                   else
6722                      Alt1 := First (Alternatives (E1));
6723                      Alt2 := First (Alternatives (E2));
6724                      loop
6725                         if Present (Alt1) /= Present (Alt2) then
6726                            return False;
6727                         elsif No (Alt1) then
6728                            return True;
6729                         end if;
6730
6731                         if not FCE (Expression (Alt1), Expression (Alt2))
6732                           or else not FCL (Discrete_Choices (Alt1),
6733                                            Discrete_Choices (Alt2))
6734                         then
6735                            return False;
6736                         end if;
6737
6738                         Next (Alt1);
6739                         Next (Alt2);
6740                      end loop;
6741                   end if;
6742                end;
6743
6744             when N_Character_Literal =>
6745                return
6746                  Char_Literal_Value (E1) = Char_Literal_Value (E2);
6747
6748             when N_Component_Association =>
6749                return
6750                  FCL (Choices (E1), Choices (E2))
6751                    and then
6752                  FCE (Expression (E1), Expression (E2));
6753
6754             when N_Conditional_Expression =>
6755                return
6756                  FCL (Expressions (E1), Expressions (E2));
6757
6758             when N_Explicit_Dereference =>
6759                return
6760                  FCE (Prefix (E1), Prefix (E2));
6761
6762             when N_Extension_Aggregate =>
6763                return
6764                  FCL (Expressions (E1), Expressions (E2))
6765                    and then Null_Record_Present (E1) =
6766                             Null_Record_Present (E2)
6767                    and then FCL (Component_Associations (E1),
6768                                Component_Associations (E2));
6769
6770             when N_Function_Call =>
6771                return
6772                  FCE (Name (E1), Name (E2))
6773                    and then
6774                  FCL (Parameter_Associations (E1),
6775                       Parameter_Associations (E2));
6776
6777             when N_Indexed_Component =>
6778                return
6779                  FCE (Prefix (E1), Prefix (E2))
6780                    and then
6781                  FCL (Expressions (E1), Expressions (E2));
6782
6783             when N_Integer_Literal =>
6784                return (Intval (E1) = Intval (E2));
6785
6786             when N_Null =>
6787                return True;
6788
6789             when N_Operator_Symbol =>
6790                return
6791                  Chars (E1) = Chars (E2);
6792
6793             when N_Others_Choice =>
6794                return True;
6795
6796             when N_Parameter_Association =>
6797                return
6798                  Chars (Selector_Name (E1))  = Chars (Selector_Name (E2))
6799                    and then FCE (Explicit_Actual_Parameter (E1),
6800                                  Explicit_Actual_Parameter (E2));
6801
6802             when N_Qualified_Expression =>
6803                return
6804                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6805                    and then
6806                  FCE (Expression (E1), Expression (E2));
6807
6808             when N_Quantified_Expression =>
6809                if not FCE (Condition (E1), Condition (E2)) then
6810                   return False;
6811                end if;
6812
6813                if Present (Loop_Parameter_Specification (E1))
6814                  and then Present (Loop_Parameter_Specification (E2))
6815                then
6816                   declare
6817                      L1 : constant Node_Id :=
6818                        Loop_Parameter_Specification (E1);
6819                      L2 : constant Node_Id :=
6820                        Loop_Parameter_Specification (E2);
6821
6822                   begin
6823                      return
6824                        Reverse_Present (L1) = Reverse_Present (L2)
6825                          and then
6826                            FCE (Defining_Identifier (L1),
6827                                 Defining_Identifier (L2))
6828                          and then
6829                            FCE (Discrete_Subtype_Definition (L1),
6830                                 Discrete_Subtype_Definition (L2));
6831                   end;
6832
6833                else   --  quantified expression with an iterator
6834                   declare
6835                      I1 : constant Node_Id := Iterator_Specification (E1);
6836                      I2 : constant Node_Id := Iterator_Specification (E2);
6837
6838                   begin
6839                      return
6840                        FCE (Defining_Identifier (I1),
6841                             Defining_Identifier (I2))
6842                        and then
6843                          Of_Present (I1) = Of_Present (I2)
6844                        and then
6845                          Reverse_Present (I1) = Reverse_Present (I2)
6846                        and then FCE (Name (I1), Name (I2))
6847                        and then FCE (Subtype_Indication (I1),
6848                                       Subtype_Indication (I2));
6849                   end;
6850                end if;
6851
6852             when N_Range =>
6853                return
6854                  FCE (Low_Bound (E1), Low_Bound (E2))
6855                    and then
6856                  FCE (High_Bound (E1), High_Bound (E2));
6857
6858             when N_Real_Literal =>
6859                return (Realval (E1) = Realval (E2));
6860
6861             when N_Selected_Component =>
6862                return
6863                  FCE (Prefix (E1), Prefix (E2))
6864                    and then
6865                  FCE (Selector_Name (E1), Selector_Name (E2));
6866
6867             when N_Slice =>
6868                return
6869                  FCE (Prefix (E1), Prefix (E2))
6870                    and then
6871                  FCE (Discrete_Range (E1), Discrete_Range (E2));
6872
6873             when N_String_Literal =>
6874                declare
6875                   S1 : constant String_Id := Strval (E1);
6876                   S2 : constant String_Id := Strval (E2);
6877                   L1 : constant Nat       := String_Length (S1);
6878                   L2 : constant Nat       := String_Length (S2);
6879
6880                begin
6881                   if L1 /= L2 then
6882                      return False;
6883
6884                   else
6885                      for J in 1 .. L1 loop
6886                         if Get_String_Char (S1, J) /=
6887                            Get_String_Char (S2, J)
6888                         then
6889                            return False;
6890                         end if;
6891                      end loop;
6892
6893                      return True;
6894                   end if;
6895                end;
6896
6897             when N_Type_Conversion =>
6898                return
6899                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6900                    and then
6901                  FCE (Expression (E1), Expression (E2));
6902
6903             when N_Unary_Op =>
6904                return
6905                  Entity (E1) = Entity (E2)
6906                    and then
6907                  FCE (Right_Opnd (E1), Right_Opnd (E2));
6908
6909             when N_Unchecked_Type_Conversion =>
6910                return
6911                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
6912                    and then
6913                  FCE (Expression (E1), Expression (E2));
6914
6915             --  All other node types cannot appear in this context. Strictly
6916             --  we should raise a fatal internal error. Instead we just ignore
6917             --  the nodes. This means that if anyone makes a mistake in the
6918             --  expander and mucks an expression tree irretrievably, the
6919             --  result will be a failure to detect a (probably very obscure)
6920             --  case of non-conformance, which is better than bombing on some
6921             --  case where two expressions do in fact conform.
6922
6923             when others =>
6924                return True;
6925
6926          end case;
6927       end if;
6928    end Fully_Conformant_Expressions;
6929
6930    ----------------------------------------
6931    -- Fully_Conformant_Discrete_Subtypes --
6932    ----------------------------------------
6933
6934    function Fully_Conformant_Discrete_Subtypes
6935      (Given_S1 : Node_Id;
6936       Given_S2 : Node_Id) return Boolean
6937    is
6938       S1 : constant Node_Id := Original_Node (Given_S1);
6939       S2 : constant Node_Id := Original_Node (Given_S2);
6940
6941       function Conforming_Bounds (B1, B2 : Node_Id) return Boolean;
6942       --  Special-case for a bound given by a discriminant, which in the body
6943       --  is replaced with the discriminal of the enclosing type.
6944
6945       function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
6946       --  Check both bounds
6947
6948       -----------------------
6949       -- Conforming_Bounds --
6950       -----------------------
6951
6952       function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
6953       begin
6954          if Is_Entity_Name (B1)
6955            and then Is_Entity_Name (B2)
6956            and then Ekind (Entity (B1)) = E_Discriminant
6957          then
6958             return Chars (B1) = Chars (B2);
6959
6960          else
6961             return Fully_Conformant_Expressions (B1, B2);
6962          end if;
6963       end Conforming_Bounds;
6964
6965       -----------------------
6966       -- Conforming_Ranges --
6967       -----------------------
6968
6969       function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
6970       begin
6971          return
6972            Conforming_Bounds (Low_Bound (R1), Low_Bound (R2))
6973              and then
6974            Conforming_Bounds (High_Bound (R1), High_Bound (R2));
6975       end Conforming_Ranges;
6976
6977    --  Start of processing for Fully_Conformant_Discrete_Subtypes
6978
6979    begin
6980       if Nkind (S1) /= Nkind (S2) then
6981          return False;
6982
6983       elsif Is_Entity_Name (S1) then
6984          return Entity (S1) = Entity (S2);
6985
6986       elsif Nkind (S1) = N_Range then
6987          return Conforming_Ranges (S1, S2);
6988
6989       elsif Nkind (S1) = N_Subtype_Indication then
6990          return
6991             Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2))
6992               and then
6993             Conforming_Ranges
6994               (Range_Expression (Constraint (S1)),
6995                Range_Expression (Constraint (S2)));
6996       else
6997          return True;
6998       end if;
6999    end Fully_Conformant_Discrete_Subtypes;
7000
7001    --------------------
7002    -- Install_Entity --
7003    --------------------
7004
7005    procedure Install_Entity (E : Entity_Id) is
7006       Prev : constant Entity_Id := Current_Entity (E);
7007    begin
7008       Set_Is_Immediately_Visible (E);
7009       Set_Current_Entity (E);
7010       Set_Homonym (E, Prev);
7011    end Install_Entity;
7012
7013    ---------------------
7014    -- Install_Formals --
7015    ---------------------
7016
7017    procedure Install_Formals (Id : Entity_Id) is
7018       F : Entity_Id;
7019    begin
7020       F := First_Formal (Id);
7021       while Present (F) loop
7022          Install_Entity (F);
7023          Next_Formal (F);
7024       end loop;
7025    end Install_Formals;
7026
7027    -----------------------------
7028    -- Is_Interface_Conformant --
7029    -----------------------------
7030
7031    function Is_Interface_Conformant
7032      (Tagged_Type : Entity_Id;
7033       Iface_Prim  : Entity_Id;
7034       Prim        : Entity_Id) return Boolean
7035    is
7036       Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim);
7037       Typ   : constant Entity_Id := Find_Dispatching_Type (Prim);
7038
7039    begin
7040       pragma Assert (Is_Subprogram (Iface_Prim)
7041         and then Is_Subprogram (Prim)
7042         and then Is_Dispatching_Operation (Iface_Prim)
7043         and then Is_Dispatching_Operation (Prim));
7044
7045       pragma Assert (Is_Interface (Iface)
7046         or else (Present (Alias (Iface_Prim))
7047                    and then
7048                      Is_Interface
7049                        (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
7050
7051       if Prim = Iface_Prim
7052         or else not Is_Subprogram (Prim)
7053         or else Ekind (Prim) /= Ekind (Iface_Prim)
7054         or else not Is_Dispatching_Operation (Prim)
7055         or else Scope (Prim) /= Scope (Tagged_Type)
7056         or else No (Typ)
7057         or else Base_Type (Typ) /= Tagged_Type
7058         or else not Primitive_Names_Match (Iface_Prim, Prim)
7059       then
7060          return False;
7061
7062       --  Case of a procedure, or a function that does not have a controlling
7063       --  result (I or access I).
7064
7065       elsif Ekind (Iface_Prim) = E_Procedure
7066         or else Etype (Prim) = Etype (Iface_Prim)
7067         or else not Has_Controlling_Result (Prim)
7068       then
7069          return Type_Conformant
7070                   (Iface_Prim, Prim, Skip_Controlling_Formals => True);
7071
7072       --  Case of a function returning an interface, or an access to one.
7073       --  Check that the return types correspond.
7074
7075       elsif Implements_Interface (Typ, Iface) then
7076          if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type)
7077               /=
7078             (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type)
7079          then
7080             return False;
7081          else
7082             return
7083               Type_Conformant (Prim, Iface_Prim,
7084                 Skip_Controlling_Formals => True);
7085          end if;
7086
7087       else
7088          return False;
7089       end if;
7090    end Is_Interface_Conformant;
7091
7092    ---------------------------------
7093    -- Is_Non_Overriding_Operation --
7094    ---------------------------------
7095
7096    function Is_Non_Overriding_Operation
7097      (Prev_E : Entity_Id;
7098       New_E  : Entity_Id) return Boolean
7099    is
7100       Formal : Entity_Id;
7101       F_Typ  : Entity_Id;
7102       G_Typ  : Entity_Id := Empty;
7103
7104       function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
7105       --  If F_Type is a derived type associated with a generic actual subtype,
7106       --  then return its Generic_Parent_Type attribute, else return Empty.
7107
7108       function Types_Correspond
7109         (P_Type : Entity_Id;
7110          N_Type : Entity_Id) return Boolean;
7111       --  Returns true if and only if the types (or designated types in the
7112       --  case of anonymous access types) are the same or N_Type is derived
7113       --  directly or indirectly from P_Type.
7114
7115       -----------------------------
7116       -- Get_Generic_Parent_Type --
7117       -----------------------------
7118
7119       function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
7120          G_Typ : Entity_Id;
7121          Indic : Node_Id;
7122
7123       begin
7124          if Is_Derived_Type (F_Typ)
7125            and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
7126          then
7127             --  The tree must be traversed to determine the parent subtype in
7128             --  the generic unit, which unfortunately isn't always available
7129             --  via semantic attributes. ??? (Note: The use of Original_Node
7130             --  is needed for cases where a full derived type has been
7131             --  rewritten.)
7132
7133             Indic := Subtype_Indication
7134                        (Type_Definition (Original_Node (Parent (F_Typ))));
7135
7136             if Nkind (Indic) = N_Subtype_Indication then
7137                G_Typ := Entity (Subtype_Mark (Indic));
7138             else
7139                G_Typ := Entity (Indic);
7140             end if;
7141
7142             if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
7143               and then Present (Generic_Parent_Type (Parent (G_Typ)))
7144             then
7145                return Generic_Parent_Type (Parent (G_Typ));
7146             end if;
7147          end if;
7148
7149          return Empty;
7150       end Get_Generic_Parent_Type;
7151
7152       ----------------------
7153       -- Types_Correspond --
7154       ----------------------
7155
7156       function Types_Correspond
7157         (P_Type : Entity_Id;
7158          N_Type : Entity_Id) return Boolean
7159       is
7160          Prev_Type : Entity_Id := Base_Type (P_Type);
7161          New_Type  : Entity_Id := Base_Type (N_Type);
7162
7163       begin
7164          if Ekind (Prev_Type) = E_Anonymous_Access_Type then
7165             Prev_Type := Designated_Type (Prev_Type);
7166          end if;
7167
7168          if Ekind (New_Type) = E_Anonymous_Access_Type then
7169             New_Type := Designated_Type (New_Type);
7170          end if;
7171
7172          if Prev_Type = New_Type then
7173             return True;
7174
7175          elsif not Is_Class_Wide_Type (New_Type) then
7176             while Etype (New_Type) /= New_Type loop
7177                New_Type := Etype (New_Type);
7178                if New_Type = Prev_Type then
7179                   return True;
7180                end if;
7181             end loop;
7182          end if;
7183          return False;
7184       end Types_Correspond;
7185
7186    --  Start of processing for Is_Non_Overriding_Operation
7187
7188    begin
7189       --  In the case where both operations are implicit derived subprograms
7190       --  then neither overrides the other. This can only occur in certain
7191       --  obscure cases (e.g., derivation from homographs created in a generic
7192       --  instantiation).
7193
7194       if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
7195          return True;
7196
7197       elsif Ekind (Current_Scope) = E_Package
7198         and then Is_Generic_Instance (Current_Scope)
7199         and then In_Private_Part (Current_Scope)
7200         and then Comes_From_Source (New_E)
7201       then
7202          --  We examine the formals and result subtype of the inherited
7203          --  operation, to determine whether their type is derived from (the
7204          --  instance of) a generic type.
7205
7206          Formal := First_Formal (Prev_E);
7207          while Present (Formal) loop
7208             F_Typ := Base_Type (Etype (Formal));
7209
7210             if Ekind (F_Typ) = E_Anonymous_Access_Type then
7211                F_Typ := Designated_Type (F_Typ);
7212             end if;
7213
7214             G_Typ := Get_Generic_Parent_Type (F_Typ);
7215
7216             Next_Formal (Formal);
7217          end loop;
7218
7219          if No (G_Typ) and then Ekind (Prev_E) = E_Function then
7220             G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
7221          end if;
7222
7223          if No (G_Typ) then
7224             return False;
7225          end if;
7226
7227          --  If the generic type is a private type, then the original operation
7228          --  was not overriding in the generic, because there was no primitive
7229          --  operation to override.
7230
7231          if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
7232            and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
7233                       N_Formal_Private_Type_Definition
7234          then
7235             return True;
7236
7237          --  The generic parent type is the ancestor of a formal derived
7238          --  type declaration. We need to check whether it has a primitive
7239          --  operation that should be overridden by New_E in the generic.
7240
7241          else
7242             declare
7243                P_Formal : Entity_Id;
7244                N_Formal : Entity_Id;
7245                P_Typ    : Entity_Id;
7246                N_Typ    : Entity_Id;
7247                P_Prim   : Entity_Id;
7248                Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
7249
7250             begin
7251                while Present (Prim_Elt) loop
7252                   P_Prim := Node (Prim_Elt);
7253
7254                   if Chars (P_Prim) = Chars (New_E)
7255                     and then Ekind (P_Prim) = Ekind (New_E)
7256                   then
7257                      P_Formal := First_Formal (P_Prim);
7258                      N_Formal := First_Formal (New_E);
7259                      while Present (P_Formal) and then Present (N_Formal) loop
7260                         P_Typ := Etype (P_Formal);
7261                         N_Typ := Etype (N_Formal);
7262
7263                         if not Types_Correspond (P_Typ, N_Typ) then
7264                            exit;
7265                         end if;
7266
7267                         Next_Entity (P_Formal);
7268                         Next_Entity (N_Formal);
7269                      end loop;
7270
7271                      --  Found a matching primitive operation belonging to the
7272                      --  formal ancestor type, so the new subprogram is
7273                      --  overriding.
7274
7275                      if No (P_Formal)
7276                        and then No (N_Formal)
7277                        and then (Ekind (New_E) /= E_Function
7278                                   or else
7279                                  Types_Correspond
7280                                    (Etype (P_Prim), Etype (New_E)))
7281                      then
7282                         return False;
7283                      end if;
7284                   end if;
7285
7286                   Next_Elmt (Prim_Elt);
7287                end loop;
7288
7289                --  If no match found, then the new subprogram does not
7290                --  override in the generic (nor in the instance).
7291
7292                return True;
7293             end;
7294          end if;
7295       else
7296          return False;
7297       end if;
7298    end Is_Non_Overriding_Operation;
7299
7300    -------------------------------------
7301    -- List_Inherited_Pre_Post_Aspects --
7302    -------------------------------------
7303
7304    procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is
7305    begin
7306       if Opt.List_Inherited_Aspects
7307         and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E))
7308       then
7309          declare
7310             Inherited : constant Subprogram_List :=
7311                           Inherited_Subprograms (E);
7312             P         : Node_Id;
7313
7314          begin
7315             for J in Inherited'Range loop
7316                P := Spec_PPC_List (Contract (Inherited (J)));
7317
7318                while Present (P) loop
7319                   Error_Msg_Sloc := Sloc (P);
7320
7321                   if Class_Present (P) and then not Split_PPC (P) then
7322                      if Pragma_Name (P) = Name_Precondition then
7323                         Error_Msg_N
7324                           ("?info: & inherits `Pre''Class` aspect from #", E);
7325                      else
7326                         Error_Msg_N
7327                           ("?info: & inherits `Post''Class` aspect from #", E);
7328                      end if;
7329                   end if;
7330
7331                   P := Next_Pragma (P);
7332                end loop;
7333             end loop;
7334          end;
7335       end if;
7336    end List_Inherited_Pre_Post_Aspects;
7337
7338    ------------------------------
7339    -- Make_Inequality_Operator --
7340    ------------------------------
7341
7342    --  S is the defining identifier of an equality operator. We build a
7343    --  subprogram declaration with the right signature. This operation is
7344    --  intrinsic, because it is always expanded as the negation of the
7345    --  call to the equality function.
7346
7347    procedure Make_Inequality_Operator (S : Entity_Id) is
7348       Loc     : constant Source_Ptr := Sloc (S);
7349       Decl    : Node_Id;
7350       Formals : List_Id;
7351       Op_Name : Entity_Id;
7352
7353       FF : constant Entity_Id := First_Formal (S);
7354       NF : constant Entity_Id := Next_Formal (FF);
7355
7356    begin
7357       --  Check that equality was properly defined, ignore call if not
7358
7359       if No (NF) then
7360          return;
7361       end if;
7362
7363       declare
7364          A : constant Entity_Id :=
7365                Make_Defining_Identifier (Sloc (FF),
7366                  Chars => Chars (FF));
7367
7368          B : constant Entity_Id :=
7369                Make_Defining_Identifier (Sloc (NF),
7370                  Chars => Chars (NF));
7371
7372       begin
7373          Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
7374
7375          Formals := New_List (
7376            Make_Parameter_Specification (Loc,
7377              Defining_Identifier => A,
7378              Parameter_Type      =>
7379                New_Reference_To (Etype (First_Formal (S)),
7380                  Sloc (Etype (First_Formal (S))))),
7381
7382            Make_Parameter_Specification (Loc,
7383              Defining_Identifier => B,
7384              Parameter_Type      =>
7385                New_Reference_To (Etype (Next_Formal (First_Formal (S))),
7386                  Sloc (Etype (Next_Formal (First_Formal (S)))))));
7387
7388          Decl :=
7389            Make_Subprogram_Declaration (Loc,
7390              Specification =>
7391                Make_Function_Specification (Loc,
7392                  Defining_Unit_Name       => Op_Name,
7393                  Parameter_Specifications => Formals,
7394                  Result_Definition        =>
7395                    New_Reference_To (Standard_Boolean, Loc)));
7396
7397          --  Insert inequality right after equality if it is explicit or after
7398          --  the derived type when implicit. These entities are created only
7399          --  for visibility purposes, and eventually replaced in the course of
7400          --  expansion, so they do not need to be attached to the tree and seen
7401          --  by the back-end. Keeping them internal also avoids spurious
7402          --  freezing problems. The declaration is inserted in the tree for
7403          --  analysis, and removed afterwards. If the equality operator comes
7404          --  from an explicit declaration, attach the inequality immediately
7405          --  after. Else the equality is inherited from a derived type
7406          --  declaration, so insert inequality after that declaration.
7407
7408          if No (Alias (S)) then
7409             Insert_After (Unit_Declaration_Node (S), Decl);
7410          elsif Is_List_Member (Parent (S)) then
7411             Insert_After (Parent (S), Decl);
7412          else
7413             Insert_After (Parent (Etype (First_Formal (S))), Decl);
7414          end if;
7415
7416          Mark_Rewrite_Insertion (Decl);
7417          Set_Is_Intrinsic_Subprogram (Op_Name);
7418          Analyze (Decl);
7419          Remove (Decl);
7420          Set_Has_Completion (Op_Name);
7421          Set_Corresponding_Equality (Op_Name, S);
7422          Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
7423       end;
7424    end Make_Inequality_Operator;
7425
7426    ----------------------
7427    -- May_Need_Actuals --
7428    ----------------------
7429
7430    procedure May_Need_Actuals (Fun : Entity_Id) is
7431       F : Entity_Id;
7432       B : Boolean;
7433
7434    begin
7435       F := First_Formal (Fun);
7436       B := True;
7437       while Present (F) loop
7438          if No (Default_Value (F)) then
7439             B := False;
7440             exit;
7441          end if;
7442
7443          Next_Formal (F);
7444       end loop;
7445
7446       Set_Needs_No_Actuals (Fun, B);
7447    end May_Need_Actuals;
7448
7449    ---------------------
7450    -- Mode_Conformant --
7451    ---------------------
7452
7453    function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
7454       Result : Boolean;
7455    begin
7456       Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
7457       return Result;
7458    end Mode_Conformant;
7459
7460    ---------------------------
7461    -- New_Overloaded_Entity --
7462    ---------------------------
7463
7464    procedure New_Overloaded_Entity
7465      (S            : Entity_Id;
7466       Derived_Type : Entity_Id := Empty)
7467    is
7468       Overridden_Subp : Entity_Id := Empty;
7469       --  Set if the current scope has an operation that is type-conformant
7470       --  with S, and becomes hidden by S.
7471
7472       Is_Primitive_Subp : Boolean;
7473       --  Set to True if the new subprogram is primitive
7474
7475       E : Entity_Id;
7476       --  Entity that S overrides
7477
7478       Prev_Vis : Entity_Id := Empty;
7479       --  Predecessor of E in Homonym chain
7480
7481       procedure Check_For_Primitive_Subprogram
7482         (Is_Primitive  : out Boolean;
7483          Is_Overriding : Boolean := False);
7484       --  If the subprogram being analyzed is a primitive operation of the type
7485       --  of a formal or result, set the Has_Primitive_Operations flag on the
7486       --  type, and set Is_Primitive to True (otherwise set to False). Set the
7487       --  corresponding flag on the entity itself for later use.
7488
7489       procedure Check_Synchronized_Overriding
7490         (Def_Id          : Entity_Id;
7491          Overridden_Subp : out Entity_Id);
7492       --  First determine if Def_Id is an entry or a subprogram either defined
7493       --  in the scope of a task or protected type, or is a primitive of such
7494       --  a type. Check whether Def_Id overrides a subprogram of an interface
7495       --  implemented by the synchronized type, return the overridden entity
7496       --  or Empty.
7497
7498       function Is_Private_Declaration (E : Entity_Id) return Boolean;
7499       --  Check that E is declared in the private part of the current package,
7500       --  or in the package body, where it may hide a previous declaration.
7501       --  We can't use In_Private_Part by itself because this flag is also
7502       --  set when freezing entities, so we must examine the place of the
7503       --  declaration in the tree, and recognize wrapper packages as well.
7504
7505       function Is_Overriding_Alias
7506         (Old_E : Entity_Id;
7507          New_E : Entity_Id) return Boolean;
7508       --  Check whether new subprogram and old subprogram are both inherited
7509       --  from subprograms that have distinct dispatch table entries. This can
7510       --  occur with derivations from instances with accidental homonyms.
7511       --  The function is conservative given that the converse is only true
7512       --  within instances that contain accidental overloadings.
7513
7514       ------------------------------------
7515       -- Check_For_Primitive_Subprogram --
7516       ------------------------------------
7517
7518       procedure Check_For_Primitive_Subprogram
7519         (Is_Primitive  : out Boolean;
7520          Is_Overriding : Boolean := False)
7521       is
7522          Formal : Entity_Id;
7523          F_Typ  : Entity_Id;
7524          B_Typ  : Entity_Id;
7525
7526          function Visible_Part_Type (T : Entity_Id) return Boolean;
7527          --  Returns true if T is declared in the visible part of the current
7528          --  package scope; otherwise returns false. Assumes that T is declared
7529          --  in a package.
7530
7531          procedure Check_Private_Overriding (T : Entity_Id);
7532          --  Checks that if a primitive abstract subprogram of a visible
7533          --  abstract type is declared in a private part, then it must override
7534          --  an abstract subprogram declared in the visible part. Also checks
7535          --  that if a primitive function with a controlling result is declared
7536          --  in a private part, then it must override a function declared in
7537          --  the visible part.
7538
7539          ------------------------------
7540          -- Check_Private_Overriding --
7541          ------------------------------
7542
7543          procedure Check_Private_Overriding (T : Entity_Id) is
7544          begin
7545             if Is_Package_Or_Generic_Package (Current_Scope)
7546               and then In_Private_Part (Current_Scope)
7547               and then Visible_Part_Type (T)
7548               and then not In_Instance
7549             then
7550                if Is_Abstract_Type (T)
7551                  and then Is_Abstract_Subprogram (S)
7552                  and then (not Is_Overriding
7553                             or else not Is_Abstract_Subprogram (E))
7554                then
7555                   Error_Msg_N
7556                     ("abstract subprograms must be visible "
7557                      & "(RM 3.9.3(10))!", S);
7558
7559                elsif Ekind (S) = E_Function
7560                  and then not Is_Overriding
7561                then
7562                   if Is_Tagged_Type (T)
7563                     and then T = Base_Type (Etype (S))
7564                   then
7565                      Error_Msg_N
7566                        ("private function with tagged result must"
7567                         & " override visible-part function", S);
7568                      Error_Msg_N
7569                        ("\move subprogram to the visible part"
7570                         & " (RM 3.9.3(10))", S);
7571
7572                   --  AI05-0073: extend this test to the case of a function
7573                   --  with a controlling access result.
7574
7575                   elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
7576                     and then Is_Tagged_Type (Designated_Type (Etype (S)))
7577                     and then
7578                       not Is_Class_Wide_Type (Designated_Type (Etype (S)))
7579                     and then Ada_Version >= Ada_2012
7580                   then
7581                      Error_Msg_N
7582                        ("private function with controlling access result "
7583                           & "must override visible-part function", S);
7584                      Error_Msg_N
7585                        ("\move subprogram to the visible part"
7586                           & " (RM 3.9.3(10))", S);
7587                   end if;
7588                end if;
7589             end if;
7590          end Check_Private_Overriding;
7591
7592          -----------------------
7593          -- Visible_Part_Type --
7594          -----------------------
7595
7596          function Visible_Part_Type (T : Entity_Id) return Boolean is
7597             P : constant Node_Id := Unit_Declaration_Node (Scope (T));
7598             N : Node_Id;
7599
7600          begin
7601             --  If the entity is a private type, then it must be declared in a
7602             --  visible part.
7603
7604             if Ekind (T) in Private_Kind then
7605                return True;
7606             end if;
7607
7608             --  Otherwise, we traverse the visible part looking for its
7609             --  corresponding declaration. We cannot use the declaration
7610             --  node directly because in the private part the entity of a
7611             --  private type is the one in the full view, which does not
7612             --  indicate that it is the completion of something visible.
7613
7614             N := First (Visible_Declarations (Specification (P)));
7615             while Present (N) loop
7616                if Nkind (N) = N_Full_Type_Declaration
7617                  and then Present (Defining_Identifier (N))
7618                  and then T = Defining_Identifier (N)
7619                then
7620                   return True;
7621
7622                elsif Nkind_In (N, N_Private_Type_Declaration,
7623                                   N_Private_Extension_Declaration)
7624                  and then Present (Defining_Identifier (N))
7625                  and then T = Full_View (Defining_Identifier (N))
7626                then
7627                   return True;
7628                end if;
7629
7630                Next (N);
7631             end loop;
7632
7633             return False;
7634          end Visible_Part_Type;
7635
7636       --  Start of processing for Check_For_Primitive_Subprogram
7637
7638       begin
7639          Is_Primitive := False;
7640
7641          if not Comes_From_Source (S) then
7642             null;
7643
7644          --  If subprogram is at library level, it is not primitive operation
7645
7646          elsif Current_Scope = Standard_Standard then
7647             null;
7648
7649          elsif (Is_Package_Or_Generic_Package (Current_Scope)
7650                  and then not In_Package_Body (Current_Scope))
7651            or else Is_Overriding
7652          then
7653             --  For function, check return type
7654
7655             if Ekind (S) = E_Function then
7656                if Ekind (Etype (S)) = E_Anonymous_Access_Type then
7657                   F_Typ := Designated_Type (Etype (S));
7658                else
7659                   F_Typ := Etype (S);
7660                end if;
7661
7662                B_Typ := Base_Type (F_Typ);
7663
7664                if Scope (B_Typ) = Current_Scope
7665                  and then not Is_Class_Wide_Type (B_Typ)
7666                  and then not Is_Generic_Type (B_Typ)
7667                then
7668                   Is_Primitive := True;
7669                   Set_Has_Primitive_Operations (B_Typ);
7670                   Set_Is_Primitive (S);
7671                   Check_Private_Overriding (B_Typ);
7672                end if;
7673             end if;
7674
7675             --  For all subprograms, check formals
7676
7677             Formal := First_Formal (S);
7678             while Present (Formal) loop
7679                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
7680                   F_Typ := Designated_Type (Etype (Formal));
7681                else
7682                   F_Typ := Etype (Formal);
7683                end if;
7684
7685                B_Typ := Base_Type (F_Typ);
7686
7687                if Ekind (B_Typ) = E_Access_Subtype then
7688                   B_Typ := Base_Type (B_Typ);
7689                end if;
7690
7691                if Scope (B_Typ) = Current_Scope
7692                  and then not Is_Class_Wide_Type (B_Typ)
7693                  and then not Is_Generic_Type (B_Typ)
7694                then
7695                   Is_Primitive := True;
7696                   Set_Is_Primitive (S);
7697                   Set_Has_Primitive_Operations (B_Typ);
7698                   Check_Private_Overriding (B_Typ);
7699                end if;
7700
7701                Next_Formal (Formal);
7702             end loop;
7703          end if;
7704       end Check_For_Primitive_Subprogram;
7705
7706       -----------------------------------
7707       -- Check_Synchronized_Overriding --
7708       -----------------------------------
7709
7710       procedure Check_Synchronized_Overriding
7711         (Def_Id          : Entity_Id;
7712          Overridden_Subp : out Entity_Id)
7713       is
7714          Ifaces_List : Elist_Id;
7715          In_Scope    : Boolean;
7716          Typ         : Entity_Id;
7717
7718          function Matches_Prefixed_View_Profile
7719            (Prim_Params  : List_Id;
7720             Iface_Params : List_Id) return Boolean;
7721          --  Determine whether a subprogram's parameter profile Prim_Params
7722          --  matches that of a potentially overridden interface subprogram
7723          --  Iface_Params. Also determine if the type of first parameter of
7724          --  Iface_Params is an implemented interface.
7725
7726          -----------------------------------
7727          -- Matches_Prefixed_View_Profile --
7728          -----------------------------------
7729
7730          function Matches_Prefixed_View_Profile
7731            (Prim_Params  : List_Id;
7732             Iface_Params : List_Id) return Boolean
7733          is
7734             Iface_Id     : Entity_Id;
7735             Iface_Param  : Node_Id;
7736             Iface_Typ    : Entity_Id;
7737             Prim_Id      : Entity_Id;
7738             Prim_Param   : Node_Id;
7739             Prim_Typ     : Entity_Id;
7740
7741             function Is_Implemented
7742               (Ifaces_List : Elist_Id;
7743                Iface       : Entity_Id) return Boolean;
7744             --  Determine if Iface is implemented by the current task or
7745             --  protected type.
7746
7747             --------------------
7748             -- Is_Implemented --
7749             --------------------
7750
7751             function Is_Implemented
7752               (Ifaces_List : Elist_Id;
7753                Iface       : Entity_Id) return Boolean
7754             is
7755                Iface_Elmt : Elmt_Id;
7756
7757             begin
7758                Iface_Elmt := First_Elmt (Ifaces_List);
7759                while Present (Iface_Elmt) loop
7760                   if Node (Iface_Elmt) = Iface then
7761                      return True;
7762                   end if;
7763
7764                   Next_Elmt (Iface_Elmt);
7765                end loop;
7766
7767                return False;
7768             end Is_Implemented;
7769
7770          --  Start of processing for Matches_Prefixed_View_Profile
7771
7772          begin
7773             Iface_Param := First (Iface_Params);
7774             Iface_Typ   := Etype (Defining_Identifier (Iface_Param));
7775
7776             if Is_Access_Type (Iface_Typ) then
7777                Iface_Typ := Designated_Type (Iface_Typ);
7778             end if;
7779
7780             Prim_Param := First (Prim_Params);
7781
7782             --  The first parameter of the potentially overridden subprogram
7783             --  must be an interface implemented by Prim.
7784
7785             if not Is_Interface (Iface_Typ)
7786               or else not Is_Implemented (Ifaces_List, Iface_Typ)
7787             then
7788                return False;
7789             end if;
7790
7791             --  The checks on the object parameters are done, move onto the
7792             --  rest of the parameters.
7793
7794             if not In_Scope then
7795                Prim_Param := Next (Prim_Param);
7796             end if;
7797
7798             Iface_Param := Next (Iface_Param);
7799             while Present (Iface_Param) and then Present (Prim_Param) loop
7800                Iface_Id  := Defining_Identifier (Iface_Param);
7801                Iface_Typ := Find_Parameter_Type (Iface_Param);
7802
7803                Prim_Id  := Defining_Identifier (Prim_Param);
7804                Prim_Typ := Find_Parameter_Type (Prim_Param);
7805
7806                if Ekind (Iface_Typ) = E_Anonymous_Access_Type
7807                  and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
7808                  and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
7809                then
7810                   Iface_Typ := Designated_Type (Iface_Typ);
7811                   Prim_Typ := Designated_Type (Prim_Typ);
7812                end if;
7813
7814                --  Case of multiple interface types inside a parameter profile
7815
7816                --     (Obj_Param : in out Iface; ...; Param : Iface)
7817
7818                --  If the interface type is implemented, then the matching type
7819                --  in the primitive should be the implementing record type.
7820
7821                if Ekind (Iface_Typ) = E_Record_Type
7822                  and then Is_Interface (Iface_Typ)
7823                  and then Is_Implemented (Ifaces_List, Iface_Typ)
7824                then
7825                   if Prim_Typ /= Typ then
7826                      return False;
7827                   end if;
7828
7829                --  The two parameters must be both mode and subtype conformant
7830
7831                elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
7832                  or else not
7833                    Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
7834                then
7835                   return False;
7836                end if;
7837
7838                Next (Iface_Param);
7839                Next (Prim_Param);
7840             end loop;
7841
7842             --  One of the two lists contains more parameters than the other
7843
7844             if Present (Iface_Param) or else Present (Prim_Param) then
7845                return False;
7846             end if;
7847
7848             return True;
7849          end Matches_Prefixed_View_Profile;
7850
7851       --  Start of processing for Check_Synchronized_Overriding
7852
7853       begin
7854          Overridden_Subp := Empty;
7855
7856          --  Def_Id must be an entry or a subprogram. We should skip predefined
7857          --  primitives internally generated by the frontend; however at this
7858          --  stage predefined primitives are still not fully decorated. As a
7859          --  minor optimization we skip here internally generated subprograms.
7860
7861          if (Ekind (Def_Id) /= E_Entry
7862               and then Ekind (Def_Id) /= E_Function
7863               and then Ekind (Def_Id) /= E_Procedure)
7864            or else not Comes_From_Source (Def_Id)
7865          then
7866             return;
7867          end if;
7868
7869          --  Search for the concurrent declaration since it contains the list
7870          --  of all implemented interfaces. In this case, the subprogram is
7871          --  declared within the scope of a protected or a task type.
7872
7873          if Present (Scope (Def_Id))
7874            and then Is_Concurrent_Type (Scope (Def_Id))
7875            and then not Is_Generic_Actual_Type (Scope (Def_Id))
7876          then
7877             Typ := Scope (Def_Id);
7878             In_Scope := True;
7879
7880          --  The enclosing scope is not a synchronized type and the subprogram
7881          --  has no formals.
7882
7883          elsif No (First_Formal (Def_Id)) then
7884             return;
7885
7886          --  The subprogram has formals and hence it may be a primitive of a
7887          --  concurrent type.
7888
7889          else
7890             Typ := Etype (First_Formal (Def_Id));
7891
7892             if Is_Access_Type (Typ) then
7893                Typ := Directly_Designated_Type (Typ);
7894             end if;
7895
7896             if Is_Concurrent_Type (Typ)
7897               and then not Is_Generic_Actual_Type (Typ)
7898             then
7899                In_Scope := False;
7900
7901             --  This case occurs when the concurrent type is declared within
7902             --  a generic unit. As a result the corresponding record has been
7903             --  built and used as the type of the first formal, we just have
7904             --  to retrieve the corresponding concurrent type.
7905
7906             elsif Is_Concurrent_Record_Type (Typ)
7907               and then Present (Corresponding_Concurrent_Type (Typ))
7908             then
7909                Typ := Corresponding_Concurrent_Type (Typ);
7910                In_Scope := False;
7911
7912             else
7913                return;
7914             end if;
7915          end if;
7916
7917          --  There is no overriding to check if is an inherited operation in a
7918          --  type derivation on for a generic actual.
7919
7920          Collect_Interfaces (Typ, Ifaces_List);
7921
7922          if Is_Empty_Elmt_List (Ifaces_List) then
7923             return;
7924          end if;
7925
7926          --  Determine whether entry or subprogram Def_Id overrides a primitive
7927          --  operation that belongs to one of the interfaces in Ifaces_List.
7928
7929          declare
7930             Candidate : Entity_Id := Empty;
7931             Hom       : Entity_Id := Empty;
7932             Iface_Typ : Entity_Id;
7933             Subp      : Entity_Id := Empty;
7934
7935          begin
7936             --  Traverse the homonym chain, looking for a potentially
7937             --  overridden subprogram that belongs to an implemented
7938             --  interface.
7939
7940             Hom := Current_Entity_In_Scope (Def_Id);
7941             while Present (Hom) loop
7942                Subp := Hom;
7943
7944                if Subp = Def_Id
7945                  or else not Is_Overloadable (Subp)
7946                  or else not Is_Primitive (Subp)
7947                  or else not Is_Dispatching_Operation (Subp)
7948                  or else not Present (Find_Dispatching_Type (Subp))
7949                  or else not Is_Interface (Find_Dispatching_Type (Subp))
7950                then
7951                   null;
7952
7953                --  Entries and procedures can override abstract or null
7954                --  interface procedures.
7955
7956                elsif (Ekind (Def_Id) = E_Procedure
7957                         or else Ekind (Def_Id) = E_Entry)
7958                  and then Ekind (Subp) = E_Procedure
7959                  and then Matches_Prefixed_View_Profile
7960                             (Parameter_Specifications (Parent (Def_Id)),
7961                              Parameter_Specifications (Parent (Subp)))
7962                then
7963                   Candidate := Subp;
7964
7965                   --  For an overridden subprogram Subp, check whether the mode
7966                   --  of its first parameter is correct depending on the kind
7967                   --  of synchronized type.
7968
7969                   declare
7970                      Formal : constant Node_Id := First_Formal (Candidate);
7971
7972                   begin
7973                      --  In order for an entry or a protected procedure to
7974                      --  override, the first parameter of the overridden
7975                      --  routine must be of mode "out", "in out" or
7976                      --  access-to-variable.
7977
7978                      if (Ekind (Candidate) = E_Entry
7979                          or else Ekind (Candidate) = E_Procedure)
7980                        and then Is_Protected_Type (Typ)
7981                        and then Ekind (Formal) /= E_In_Out_Parameter
7982                        and then Ekind (Formal) /= E_Out_Parameter
7983                        and then Nkind (Parameter_Type (Parent (Formal)))
7984                                   /= N_Access_Definition
7985                      then
7986                         null;
7987
7988                      --  All other cases are OK since a task entry or routine
7989                      --  does not have a restriction on the mode of the first
7990                      --  parameter of the overridden interface routine.
7991
7992                      else
7993                         Overridden_Subp := Candidate;
7994                         return;
7995                      end if;
7996                   end;
7997
7998                --  Functions can override abstract interface functions
7999
8000                elsif Ekind (Def_Id) = E_Function
8001                  and then Ekind (Subp) = E_Function
8002                  and then Matches_Prefixed_View_Profile
8003                             (Parameter_Specifications (Parent (Def_Id)),
8004                              Parameter_Specifications (Parent (Subp)))
8005                  and then Etype (Result_Definition (Parent (Def_Id))) =
8006                           Etype (Result_Definition (Parent (Subp)))
8007                then
8008                   Overridden_Subp := Subp;
8009                   return;
8010                end if;
8011
8012                Hom := Homonym (Hom);
8013             end loop;
8014
8015             --  After examining all candidates for overriding, we are left with
8016             --  the best match which is a mode incompatible interface routine.
8017             --  Do not emit an error if the Expander is active since this error
8018             --  will be detected later on after all concurrent types are
8019             --  expanded and all wrappers are built. This check is meant for
8020             --  spec-only compilations.
8021
8022             if Present (Candidate) and then not Expander_Active then
8023                Iface_Typ :=
8024                  Find_Parameter_Type (Parent (First_Formal (Candidate)));
8025
8026                --  Def_Id is primitive of a protected type, declared inside the
8027                --  type, and the candidate is primitive of a limited or
8028                --  synchronized interface.
8029
8030                if In_Scope
8031                  and then Is_Protected_Type (Typ)
8032                  and then
8033                    (Is_Limited_Interface (Iface_Typ)
8034                       or else Is_Protected_Interface (Iface_Typ)
8035                       or else Is_Synchronized_Interface (Iface_Typ)
8036                       or else Is_Task_Interface (Iface_Typ))
8037                then
8038                   Error_Msg_NE
8039                     ("first formal of & must be of mode `OUT`, `IN OUT`"
8040                       & " or access-to-variable", Typ, Candidate);
8041                   Error_Msg_N
8042                     ("\in order to be overridden by protected procedure or "
8043                       & "entry (RM 9.4(11.9/2))", Typ);
8044                end if;
8045             end if;
8046
8047             Overridden_Subp := Candidate;
8048             return;
8049          end;
8050       end Check_Synchronized_Overriding;
8051
8052       ----------------------------
8053       -- Is_Private_Declaration --
8054       ----------------------------
8055
8056       function Is_Private_Declaration (E : Entity_Id) return Boolean is
8057          Priv_Decls : List_Id;
8058          Decl       : constant Node_Id := Unit_Declaration_Node (E);
8059
8060       begin
8061          if Is_Package_Or_Generic_Package (Current_Scope)
8062            and then In_Private_Part (Current_Scope)
8063          then
8064             Priv_Decls :=
8065               Private_Declarations (
8066                 Specification (Unit_Declaration_Node (Current_Scope)));
8067
8068             return In_Package_Body (Current_Scope)
8069               or else
8070                 (Is_List_Member (Decl)
8071                    and then List_Containing (Decl) = Priv_Decls)
8072               or else (Nkind (Parent (Decl)) = N_Package_Specification
8073                          and then not
8074                            Is_Compilation_Unit
8075                              (Defining_Entity (Parent (Decl)))
8076                          and then List_Containing (Parent (Parent (Decl)))
8077                                     = Priv_Decls);
8078          else
8079             return False;
8080          end if;
8081       end Is_Private_Declaration;
8082
8083       --------------------------
8084       -- Is_Overriding_Alias --
8085       --------------------------
8086
8087       function Is_Overriding_Alias
8088         (Old_E : Entity_Id;
8089          New_E : Entity_Id) return Boolean
8090       is
8091          AO : constant Entity_Id := Alias (Old_E);
8092          AN : constant Entity_Id := Alias (New_E);
8093
8094       begin
8095          return Scope (AO) /= Scope (AN)
8096            or else No (DTC_Entity (AO))
8097            or else No (DTC_Entity (AN))
8098            or else DT_Position (AO) = DT_Position (AN);
8099       end Is_Overriding_Alias;
8100
8101    --  Start of processing for New_Overloaded_Entity
8102
8103    begin
8104       --  We need to look for an entity that S may override. This must be a
8105       --  homonym in the current scope, so we look for the first homonym of
8106       --  S in the current scope as the starting point for the search.
8107
8108       E := Current_Entity_In_Scope (S);
8109
8110       --  Ada 2005 (AI-251): Derivation of abstract interface primitives.
8111       --  They are directly added to the list of primitive operations of
8112       --  Derived_Type, unless this is a rederivation in the private part
8113       --  of an operation that was already derived in the visible part of
8114       --  the current package.
8115
8116       if Ada_Version >= Ada_2005
8117         and then Present (Derived_Type)
8118         and then Present (Alias (S))
8119         and then Is_Dispatching_Operation (Alias (S))
8120         and then Present (Find_Dispatching_Type (Alias (S)))
8121         and then Is_Interface (Find_Dispatching_Type (Alias (S)))
8122       then
8123          --  For private types, when the full-view is processed we propagate to
8124          --  the full view the non-overridden entities whose attribute "alias"
8125          --  references an interface primitive. These entities were added by
8126          --  Derive_Subprograms to ensure that interface primitives are
8127          --  covered.
8128
8129          --  Inside_Freeze_Actions is non zero when S corresponds with an
8130          --  internal entity that links an interface primitive with its
8131          --  covering primitive through attribute Interface_Alias (see
8132          --  Add_Internal_Interface_Entities).
8133
8134          if Inside_Freezing_Actions = 0
8135            and then Is_Package_Or_Generic_Package (Current_Scope)
8136            and then In_Private_Part (Current_Scope)
8137            and then Nkind (Parent (E)) = N_Private_Extension_Declaration
8138            and then Nkind (Parent (S)) = N_Full_Type_Declaration
8139            and then Full_View (Defining_Identifier (Parent (E)))
8140                       = Defining_Identifier (Parent (S))
8141            and then Alias (E) = Alias (S)
8142          then
8143             Check_Operation_From_Private_View (S, E);
8144             Set_Is_Dispatching_Operation (S);
8145
8146          --  Common case
8147
8148          else
8149             Enter_Overloaded_Entity (S);
8150             Check_Dispatching_Operation (S, Empty);
8151             Check_For_Primitive_Subprogram (Is_Primitive_Subp);
8152          end if;
8153
8154          return;
8155       end if;
8156
8157       --  If there is no homonym then this is definitely not overriding
8158
8159       if No (E) then
8160          Enter_Overloaded_Entity (S);
8161          Check_Dispatching_Operation (S, Empty);
8162          Check_For_Primitive_Subprogram (Is_Primitive_Subp);
8163
8164          --  If subprogram has an explicit declaration, check whether it
8165          --  has an overriding indicator.
8166
8167          if Comes_From_Source (S) then
8168             Check_Synchronized_Overriding (S, Overridden_Subp);
8169
8170             --  (Ada 2012: AI05-0125-1): If S is a dispatching operation then
8171             --  it may have overridden some hidden inherited primitive. Update
8172             --  Overridden_Subp to avoid spurious errors when checking the
8173             --  overriding indicator.
8174
8175             if Ada_Version >= Ada_2012
8176               and then No (Overridden_Subp)
8177               and then Is_Dispatching_Operation (S)
8178               and then Present (Overridden_Operation (S))
8179             then
8180                Overridden_Subp := Overridden_Operation (S);
8181             end if;
8182
8183             Check_Overriding_Indicator
8184               (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
8185          end if;
8186
8187       --  If there is a homonym that is not overloadable, then we have an
8188       --  error, except for the special cases checked explicitly below.
8189
8190       elsif not Is_Overloadable (E) then
8191
8192          --  Check for spurious conflict produced by a subprogram that has the
8193          --  same name as that of the enclosing generic package. The conflict
8194          --  occurs within an instance, between the subprogram and the renaming
8195          --  declaration for the package. After the subprogram, the package
8196          --  renaming declaration becomes hidden.
8197
8198          if Ekind (E) = E_Package
8199            and then Present (Renamed_Object (E))
8200            and then Renamed_Object (E) = Current_Scope
8201            and then Nkind (Parent (Renamed_Object (E))) =
8202                                                      N_Package_Specification
8203            and then Present (Generic_Parent (Parent (Renamed_Object (E))))
8204          then
8205             Set_Is_Hidden (E);
8206             Set_Is_Immediately_Visible (E, False);
8207             Enter_Overloaded_Entity (S);
8208             Set_Homonym (S, Homonym (E));
8209             Check_Dispatching_Operation (S, Empty);
8210             Check_Overriding_Indicator (S, Empty, Is_Primitive => False);
8211
8212          --  If the subprogram is implicit it is hidden by the previous
8213          --  declaration. However if it is dispatching, it must appear in the
8214          --  dispatch table anyway, because it can be dispatched to even if it
8215          --  cannot be called directly.
8216
8217          elsif Present (Alias (S)) and then not Comes_From_Source (S) then
8218             Set_Scope (S, Current_Scope);
8219
8220             if Is_Dispatching_Operation (Alias (S)) then
8221                Check_Dispatching_Operation (S, Empty);
8222             end if;
8223
8224             return;
8225
8226          else
8227             Error_Msg_Sloc := Sloc (E);
8228
8229             --  Generate message, with useful additional warning if in generic
8230
8231             if Is_Generic_Unit (E) then
8232                Error_Msg_N ("previous generic unit cannot be overloaded", S);
8233                Error_Msg_N ("\& conflicts with declaration#", S);
8234             else
8235                Error_Msg_N ("& conflicts with declaration#", S);
8236             end if;
8237
8238             return;
8239          end if;
8240
8241       --  E exists and is overloadable
8242
8243       else
8244          Check_Synchronized_Overriding (S, Overridden_Subp);
8245
8246          --  Loop through E and its homonyms to determine if any of them is
8247          --  the candidate for overriding by S.
8248
8249          while Present (E) loop
8250
8251             --  Definitely not interesting if not in the current scope
8252
8253             if Scope (E) /= Current_Scope then
8254                null;
8255
8256             --  Check if we have type conformance
8257
8258             elsif Type_Conformant (E, S) then
8259
8260                --  If the old and new entities have the same profile and one
8261                --  is not the body of the other, then this is an error, unless
8262                --  one of them is implicitly declared.
8263
8264                --  There are some cases when both can be implicit, for example
8265                --  when both a literal and a function that overrides it are
8266                --  inherited in a derivation, or when an inherited operation
8267                --  of a tagged full type overrides the inherited operation of
8268                --  a private extension. Ada 83 had a special rule for the
8269                --  literal case. In Ada95, the later implicit operation hides
8270                --  the former, and the literal is always the former. In the
8271                --  odd case where both are derived operations declared at the
8272                --  same point, both operations should be declared, and in that
8273                --  case we bypass the following test and proceed to the next
8274                --  part. This can only occur for certain obscure cases in
8275                --  instances, when an operation on a type derived from a formal
8276                --  private type does not override a homograph inherited from
8277                --  the actual. In subsequent derivations of such a type, the
8278                --  DT positions of these operations remain distinct, if they
8279                --  have been set.
8280
8281                if Present (Alias (S))
8282                  and then (No (Alias (E))
8283                             or else Comes_From_Source (E)
8284                             or else Is_Abstract_Subprogram (S)
8285                             or else
8286                               (Is_Dispatching_Operation (E)
8287                                  and then Is_Overriding_Alias (E, S)))
8288                  and then Ekind (E) /= E_Enumeration_Literal
8289                then
8290                   --  When an derived operation is overloaded it may be due to
8291                   --  the fact that the full view of a private extension
8292                   --  re-inherits. It has to be dealt with.
8293
8294                   if Is_Package_Or_Generic_Package (Current_Scope)
8295                     and then In_Private_Part (Current_Scope)
8296                   then
8297                      Check_Operation_From_Private_View (S, E);
8298                   end if;
8299
8300                   --  In any case the implicit operation remains hidden by the
8301                   --  existing declaration, which is overriding. Indicate that
8302                   --  E overrides the operation from which S is inherited.
8303
8304                   if Present (Alias (S)) then
8305                      Set_Overridden_Operation (E, Alias (S));
8306                   else
8307                      Set_Overridden_Operation (E, S);
8308                   end if;
8309
8310                   if Comes_From_Source (E) then
8311                      Check_Overriding_Indicator (E, S, Is_Primitive => False);
8312                   end if;
8313
8314                   return;
8315
8316                --  Within an instance, the renaming declarations for actual
8317                --  subprograms may become ambiguous, but they do not hide each
8318                --  other.
8319
8320                elsif Ekind (E) /= E_Entry
8321                  and then not Comes_From_Source (E)
8322                  and then not Is_Generic_Instance (E)
8323                  and then (Present (Alias (E))
8324                             or else Is_Intrinsic_Subprogram (E))
8325                  and then (not In_Instance
8326                             or else No (Parent (E))
8327                             or else Nkind (Unit_Declaration_Node (E)) /=
8328                                       N_Subprogram_Renaming_Declaration)
8329                then
8330                   --  A subprogram child unit is not allowed to override an
8331                   --  inherited subprogram (10.1.1(20)).
8332
8333                   if Is_Child_Unit (S) then
8334                      Error_Msg_N
8335                        ("child unit overrides inherited subprogram in parent",
8336                         S);
8337                      return;
8338                   end if;
8339
8340                   if Is_Non_Overriding_Operation (E, S) then
8341                      Enter_Overloaded_Entity (S);
8342
8343                      if No (Derived_Type)
8344                        or else Is_Tagged_Type (Derived_Type)
8345                      then
8346                         Check_Dispatching_Operation (S, Empty);
8347                      end if;
8348
8349                      return;
8350                   end if;
8351
8352                   --  E is a derived operation or an internal operator which
8353                   --  is being overridden. Remove E from further visibility.
8354                   --  Furthermore, if E is a dispatching operation, it must be
8355                   --  replaced in the list of primitive operations of its type
8356                   --  (see Override_Dispatching_Operation).
8357
8358                   Overridden_Subp := E;
8359
8360                   declare
8361                      Prev : Entity_Id;
8362
8363                   begin
8364                      Prev := First_Entity (Current_Scope);
8365                      while Present (Prev)
8366                        and then Next_Entity (Prev) /= E
8367                      loop
8368                         Next_Entity (Prev);
8369                      end loop;
8370
8371                      --  It is possible for E to be in the current scope and
8372                      --  yet not in the entity chain. This can only occur in a
8373                      --  generic context where E is an implicit concatenation
8374                      --  in the formal part, because in a generic body the
8375                      --  entity chain starts with the formals.
8376
8377                      pragma Assert
8378                        (Present (Prev) or else Chars (E) = Name_Op_Concat);
8379
8380                      --  E must be removed both from the entity_list of the
8381                      --  current scope, and from the visibility chain
8382
8383                      if Debug_Flag_E then
8384                         Write_Str ("Override implicit operation ");
8385                         Write_Int (Int (E));
8386                         Write_Eol;
8387                      end if;
8388
8389                      --  If E is a predefined concatenation, it stands for four
8390                      --  different operations. As a result, a single explicit
8391                      --  declaration does not hide it. In a possible ambiguous
8392                      --  situation, Disambiguate chooses the user-defined op,
8393                      --  so it is correct to retain the previous internal one.
8394
8395                      if Chars (E) /= Name_Op_Concat
8396                        or else Ekind (E) /= E_Operator
8397                      then
8398                         --  For nondispatching derived operations that are
8399                         --  overridden by a subprogram declared in the private
8400                         --  part of a package, we retain the derived subprogram
8401                         --  but mark it as not immediately visible. If the
8402                         --  derived operation was declared in the visible part
8403                         --  then this ensures that it will still be visible
8404                         --  outside the package with the proper signature
8405                         --  (calls from outside must also be directed to this
8406                         --  version rather than the overriding one, unlike the
8407                         --  dispatching case). Calls from inside the package
8408                         --  will still resolve to the overriding subprogram
8409                         --  since the derived one is marked as not visible
8410                         --  within the package.
8411
8412                         --  If the private operation is dispatching, we achieve
8413                         --  the overriding by keeping the implicit operation
8414                         --  but setting its alias to be the overriding one. In
8415                         --  this fashion the proper body is executed in all
8416                         --  cases, but the original signature is used outside
8417                         --  of the package.
8418
8419                         --  If the overriding is not in the private part, we
8420                         --  remove the implicit operation altogether.
8421
8422                         if Is_Private_Declaration (S) then
8423                            if not Is_Dispatching_Operation (E) then
8424                               Set_Is_Immediately_Visible (E, False);
8425                            else
8426                               --  Work done in Override_Dispatching_Operation,
8427                               --  so nothing else need to be done here.
8428
8429                               null;
8430                            end if;
8431
8432                         else
8433                            --  Find predecessor of E in Homonym chain
8434
8435                            if E = Current_Entity (E) then
8436                               Prev_Vis := Empty;
8437                            else
8438                               Prev_Vis := Current_Entity (E);
8439                               while Homonym (Prev_Vis) /= E loop
8440                                  Prev_Vis := Homonym (Prev_Vis);
8441                               end loop;
8442                            end if;
8443
8444                            if Prev_Vis /= Empty then
8445
8446                               --  Skip E in the visibility chain
8447
8448                               Set_Homonym (Prev_Vis, Homonym (E));
8449
8450                            else
8451                               Set_Name_Entity_Id (Chars (E), Homonym (E));
8452                            end if;
8453
8454                            Set_Next_Entity (Prev, Next_Entity (E));
8455
8456                            if No (Next_Entity (Prev)) then
8457                               Set_Last_Entity (Current_Scope, Prev);
8458                            end if;
8459                         end if;
8460                      end if;
8461
8462                      Enter_Overloaded_Entity (S);
8463
8464                      --  For entities generated by Derive_Subprograms the
8465                      --  overridden operation is the inherited primitive
8466                      --  (which is available through the attribute alias).
8467
8468                      if not (Comes_From_Source (E))
8469                        and then Is_Dispatching_Operation (E)
8470                        and then Find_Dispatching_Type (E) =
8471                                 Find_Dispatching_Type (S)
8472                        and then Present (Alias (E))
8473                        and then Comes_From_Source (Alias (E))
8474                      then
8475                         Set_Overridden_Operation (S, Alias (E));
8476
8477                      --  Normal case of setting entity as overridden
8478
8479                      --  Note: Static_Initialization and Overridden_Operation
8480                      --  attributes use the same field in subprogram entities.
8481                      --  Static_Initialization is only defined for internal
8482                      --  initialization procedures, where Overridden_Operation
8483                      --  is irrelevant. Therefore the setting of this attribute
8484                      --  must check whether the target is an init_proc.
8485
8486                      elsif not Is_Init_Proc (S) then
8487                         Set_Overridden_Operation (S, E);
8488                      end if;
8489
8490                      Check_Overriding_Indicator (S, E, Is_Primitive => True);
8491
8492                      --  If S is a user-defined subprogram or a null procedure
8493                      --  expanded to override an inherited null procedure, or a
8494                      --  predefined dispatching primitive then indicate that E
8495                      --  overrides the operation from which S is inherited.
8496
8497                      if Comes_From_Source (S)
8498                        or else
8499                          (Present (Parent (S))
8500                            and then
8501                              Nkind (Parent (S)) = N_Procedure_Specification
8502                            and then
8503                              Null_Present (Parent (S)))
8504                        or else
8505                          (Present (Alias (E))
8506                            and then
8507                              Is_Predefined_Dispatching_Operation (Alias (E)))
8508                      then
8509                         if Present (Alias (E)) then
8510                            Set_Overridden_Operation (S, Alias (E));
8511                         end if;
8512                      end if;
8513
8514                      if Is_Dispatching_Operation (E) then
8515
8516                         --  An overriding dispatching subprogram inherits the
8517                         --  convention of the overridden subprogram (AI-117).
8518
8519                         Set_Convention (S, Convention (E));
8520                         Check_Dispatching_Operation (S, E);
8521
8522                      else
8523                         Check_Dispatching_Operation (S, Empty);
8524                      end if;
8525
8526                      Check_For_Primitive_Subprogram
8527                        (Is_Primitive_Subp, Is_Overriding => True);
8528                      goto Check_Inequality;
8529                   end;
8530
8531                --  Apparent redeclarations in instances can occur when two
8532                --  formal types get the same actual type. The subprograms in
8533                --  in the instance are legal,  even if not callable from the
8534                --  outside. Calls from within are disambiguated elsewhere.
8535                --  For dispatching operations in the visible part, the usual
8536                --  rules apply, and operations with the same profile are not
8537                --  legal (B830001).
8538
8539                elsif (In_Instance_Visible_Part
8540                        and then not Is_Dispatching_Operation (E))
8541                  or else In_Instance_Not_Visible
8542                then
8543                   null;
8544
8545                --  Here we have a real error (identical profile)
8546
8547                else
8548                   Error_Msg_Sloc := Sloc (E);
8549
8550                   --  Avoid cascaded errors if the entity appears in
8551                   --  subsequent calls.
8552
8553                   Set_Scope (S, Current_Scope);
8554
8555                   --  Generate error, with extra useful warning for the case
8556                   --  of a generic instance with no completion.
8557
8558                   if Is_Generic_Instance (S)
8559                     and then not Has_Completion (E)
8560                   then
8561                      Error_Msg_N
8562                        ("instantiation cannot provide body for&", S);
8563                      Error_Msg_N ("\& conflicts with declaration#", S);
8564                   else
8565                      Error_Msg_N ("& conflicts with declaration#", S);
8566                   end if;
8567
8568                   return;
8569                end if;
8570
8571             else
8572                --  If one subprogram has an access parameter and the other
8573                --  a parameter of an access type, calls to either might be
8574                --  ambiguous. Verify that parameters match except for the
8575                --  access parameter.
8576
8577                if May_Hide_Profile then
8578                   declare
8579                      F1 : Entity_Id;
8580                      F2 : Entity_Id;
8581
8582                   begin
8583                      F1 := First_Formal (S);
8584                      F2 := First_Formal (E);
8585                      while Present (F1) and then Present (F2) loop
8586                         if Is_Access_Type (Etype (F1)) then
8587                            if not Is_Access_Type (Etype (F2))
8588                               or else not Conforming_Types
8589                                 (Designated_Type (Etype (F1)),
8590                                  Designated_Type (Etype (F2)),
8591                                  Type_Conformant)
8592                            then
8593                               May_Hide_Profile := False;
8594                            end if;
8595
8596                         elsif
8597                           not Conforming_Types
8598                             (Etype (F1), Etype (F2), Type_Conformant)
8599                         then
8600                            May_Hide_Profile := False;
8601                         end if;
8602
8603                         Next_Formal (F1);
8604                         Next_Formal (F2);
8605                      end loop;
8606
8607                      if May_Hide_Profile
8608                        and then No (F1)
8609                        and then No (F2)
8610                      then
8611                         Error_Msg_NE ("calls to& may be ambiguous?", S, S);
8612                      end if;
8613                   end;
8614                end if;
8615             end if;
8616
8617             E := Homonym (E);
8618          end loop;
8619
8620          --  On exit, we know that S is a new entity
8621
8622          Enter_Overloaded_Entity (S);
8623          Check_For_Primitive_Subprogram (Is_Primitive_Subp);
8624          Check_Overriding_Indicator
8625            (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
8626
8627          --  Overloading is not allowed in SPARK, except for operators
8628
8629          if Nkind (S) /= N_Defining_Operator_Symbol then
8630             Error_Msg_Sloc := Sloc (Homonym (S));
8631             Check_SPARK_Restriction
8632               ("overloading not allowed with entity#", S);
8633          end if;
8634
8635          --  If S is a derived operation for an untagged type then by
8636          --  definition it's not a dispatching operation (even if the parent
8637          --  operation was dispatching), so Check_Dispatching_Operation is not
8638          --  called in that case.
8639
8640          if No (Derived_Type)
8641            or else Is_Tagged_Type (Derived_Type)
8642          then
8643             Check_Dispatching_Operation (S, Empty);
8644          end if;
8645       end if;
8646
8647       --  If this is a user-defined equality operator that is not a derived
8648       --  subprogram, create the corresponding inequality. If the operation is
8649       --  dispatching, the expansion is done elsewhere, and we do not create
8650       --  an explicit inequality operation.
8651
8652       <<Check_Inequality>>
8653          if Chars (S) = Name_Op_Eq
8654            and then Etype (S) = Standard_Boolean
8655            and then Present (Parent (S))
8656            and then not Is_Dispatching_Operation (S)
8657          then
8658             Make_Inequality_Operator (S);
8659
8660             if Ada_Version >= Ada_2012 then
8661                Check_Untagged_Equality (S);
8662             end if;
8663          end if;
8664    end New_Overloaded_Entity;
8665
8666    ---------------------
8667    -- Process_Formals --
8668    ---------------------
8669
8670    procedure Process_Formals
8671      (T           : List_Id;
8672       Related_Nod : Node_Id)
8673    is
8674       Param_Spec  : Node_Id;
8675       Formal      : Entity_Id;
8676       Formal_Type : Entity_Id;
8677       Default     : Node_Id;
8678       Ptype       : Entity_Id;
8679
8680       Num_Out_Params  : Nat       := 0;
8681       First_Out_Param : Entity_Id := Empty;
8682       --  Used for setting Is_Only_Out_Parameter
8683
8684       function Designates_From_With_Type (Typ : Entity_Id) return Boolean;
8685       --  Determine whether an access type designates a type coming from a
8686       --  limited view.
8687
8688       function Is_Class_Wide_Default (D : Node_Id) return Boolean;
8689       --  Check whether the default has a class-wide type. After analysis the
8690       --  default has the type of the formal, so we must also check explicitly
8691       --  for an access attribute.
8692
8693       -------------------------------
8694       -- Designates_From_With_Type --
8695       -------------------------------
8696
8697       function Designates_From_With_Type (Typ : Entity_Id) return Boolean is
8698          Desig : Entity_Id := Typ;
8699
8700       begin
8701          if Is_Access_Type (Desig) then
8702             Desig := Directly_Designated_Type (Desig);
8703          end if;
8704
8705          if Is_Class_Wide_Type (Desig) then
8706             Desig := Root_Type (Desig);
8707          end if;
8708
8709          return
8710            Ekind (Desig) = E_Incomplete_Type
8711              and then From_With_Type (Desig);
8712       end Designates_From_With_Type;
8713
8714       ---------------------------
8715       -- Is_Class_Wide_Default --
8716       ---------------------------
8717
8718       function Is_Class_Wide_Default (D : Node_Id) return Boolean is
8719       begin
8720          return Is_Class_Wide_Type (Designated_Type (Etype (D)))
8721            or else (Nkind (D) =  N_Attribute_Reference
8722                      and then Attribute_Name (D) = Name_Access
8723                      and then Is_Class_Wide_Type (Etype (Prefix (D))));
8724       end Is_Class_Wide_Default;
8725
8726    --  Start of processing for Process_Formals
8727
8728    begin
8729       --  In order to prevent premature use of the formals in the same formal
8730       --  part, the Ekind is left undefined until all default expressions are
8731       --  analyzed. The Ekind is established in a separate loop at the end.
8732
8733       Param_Spec := First (T);
8734       while Present (Param_Spec) loop
8735          Formal := Defining_Identifier (Param_Spec);
8736          Set_Never_Set_In_Source (Formal, True);
8737          Enter_Name (Formal);
8738
8739          --  Case of ordinary parameters
8740
8741          if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
8742             Find_Type (Parameter_Type (Param_Spec));
8743             Ptype := Parameter_Type (Param_Spec);
8744
8745             if Ptype = Error then
8746                goto Continue;
8747             end if;
8748
8749             Formal_Type := Entity (Ptype);
8750
8751             if Is_Incomplete_Type (Formal_Type)
8752               or else
8753                (Is_Class_Wide_Type (Formal_Type)
8754                   and then Is_Incomplete_Type (Root_Type (Formal_Type)))
8755             then
8756                --  Ada 2005 (AI-326): Tagged incomplete types allowed in
8757                --  primitive operations, as long as their completion is
8758                --  in the same declarative part. If in the private part
8759                --  this means that the type cannot be a Taft-amendment type.
8760                --  Check is done on package exit. For access to subprograms,
8761                --  the use is legal for Taft-amendment types.
8762
8763                if Is_Tagged_Type (Formal_Type) then
8764                   if Ekind (Scope (Current_Scope)) = E_Package
8765                     and then not From_With_Type (Formal_Type)
8766                     and then not Is_Class_Wide_Type (Formal_Type)
8767                   then
8768                      if not Nkind_In
8769                        (Parent (T), N_Access_Function_Definition,
8770                                     N_Access_Procedure_Definition)
8771                      then
8772                         Append_Elmt
8773                           (Current_Scope,
8774                              Private_Dependents (Base_Type (Formal_Type)));
8775
8776                         --  Freezing is delayed to ensure that Register_Prim
8777                         --  will get called for this operation, which is needed
8778                         --  in cases where static dispatch tables aren't built.
8779                         --  (Note that the same is done for controlling access
8780                         --  parameter cases in function Access_Definition.)
8781
8782                         Set_Has_Delayed_Freeze (Current_Scope);
8783                      end if;
8784                   end if;
8785
8786                --  Special handling of Value_Type for CIL case
8787
8788                elsif Is_Value_Type (Formal_Type) then
8789                   null;
8790
8791                elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
8792                                                N_Access_Procedure_Definition)
8793                then
8794
8795                   --  AI05-0151: Tagged incomplete types are allowed in all
8796                   --  formal parts. Untagged incomplete types are not allowed
8797                   --  in bodies.
8798
8799                   if Ada_Version >= Ada_2012 then
8800                      if Is_Tagged_Type (Formal_Type) then
8801                         null;
8802
8803                      elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement,
8804                                                           N_Entry_Body,
8805                                                           N_Subprogram_Body)
8806                      then
8807                         Error_Msg_NE
8808                           ("invalid use of untagged incomplete type&",
8809                            Ptype, Formal_Type);
8810                      end if;
8811
8812                   else
8813                      Error_Msg_NE
8814                        ("invalid use of incomplete type&",
8815                         Param_Spec, Formal_Type);
8816
8817                      --  Further checks on the legality of incomplete types
8818                      --  in formal parts are delayed until the freeze point
8819                      --  of the enclosing subprogram or access to subprogram.
8820                   end if;
8821                end if;
8822
8823             elsif Ekind (Formal_Type) = E_Void then
8824                Error_Msg_NE
8825                  ("premature use of&",
8826                   Parameter_Type (Param_Spec), Formal_Type);
8827             end if;
8828
8829             --  Ada 2005 (AI-231): Create and decorate an internal subtype
8830             --  declaration corresponding to the null-excluding type of the
8831             --  formal in the enclosing scope. Finally, replace the parameter
8832             --  type of the formal with the internal subtype.
8833
8834             if Ada_Version >= Ada_2005
8835               and then Null_Exclusion_Present (Param_Spec)
8836             then
8837                if not Is_Access_Type (Formal_Type) then
8838                   Error_Msg_N
8839                     ("`NOT NULL` allowed only for an access type", Param_Spec);
8840
8841                else
8842                   if Can_Never_Be_Null (Formal_Type)
8843                     and then Comes_From_Source (Related_Nod)
8844                   then
8845                      Error_Msg_NE
8846                        ("`NOT NULL` not allowed (& already excludes null)",
8847                         Param_Spec, Formal_Type);
8848                   end if;
8849
8850                   Formal_Type :=
8851                     Create_Null_Excluding_Itype
8852                       (T           => Formal_Type,
8853                        Related_Nod => Related_Nod,
8854                        Scope_Id    => Scope (Current_Scope));
8855
8856                   --  If the designated type of the itype is an itype we
8857                   --  decorate it with the Has_Delayed_Freeze attribute to
8858                   --  avoid problems with the backend.
8859
8860                   --  Example:
8861                   --     type T is access procedure;
8862                   --     procedure Op (O : not null T);
8863
8864                   if Is_Itype (Directly_Designated_Type (Formal_Type)) then
8865                      Set_Has_Delayed_Freeze (Formal_Type);
8866                   end if;
8867                end if;
8868             end if;
8869
8870          --  An access formal type
8871
8872          else
8873             Formal_Type :=
8874               Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
8875
8876             --  No need to continue if we already notified errors
8877
8878             if not Present (Formal_Type) then
8879                return;
8880             end if;
8881
8882             --  Ada 2005 (AI-254)
8883
8884             declare
8885                AD : constant Node_Id :=
8886                       Access_To_Subprogram_Definition
8887                         (Parameter_Type (Param_Spec));
8888             begin
8889                if Present (AD) and then Protected_Present (AD) then
8890                   Formal_Type :=
8891                     Replace_Anonymous_Access_To_Protected_Subprogram
8892                       (Param_Spec);
8893                end if;
8894             end;
8895          end if;
8896
8897          Set_Etype (Formal, Formal_Type);
8898
8899          Default := Expression (Param_Spec);
8900
8901          if Present (Default) then
8902             Check_SPARK_Restriction
8903               ("default expression is not allowed", Default);
8904
8905             if Out_Present (Param_Spec) then
8906                Error_Msg_N
8907                  ("default initialization only allowed for IN parameters",
8908                   Param_Spec);
8909             end if;
8910
8911             --  Do the special preanalysis of the expression (see section on
8912             --  "Handling of Default Expressions" in the spec of package Sem).
8913
8914             Preanalyze_Spec_Expression (Default, Formal_Type);
8915
8916             --  An access to constant cannot be the default for
8917             --  an access parameter that is an access to variable.
8918
8919             if Ekind (Formal_Type) = E_Anonymous_Access_Type
8920               and then not Is_Access_Constant (Formal_Type)
8921               and then Is_Access_Type (Etype (Default))
8922               and then Is_Access_Constant (Etype (Default))
8923             then
8924                Error_Msg_N
8925                  ("formal that is access to variable cannot be initialized " &
8926                     "with an access-to-constant expression", Default);
8927             end if;
8928
8929             --  Check that the designated type of an access parameter's default
8930             --  is not a class-wide type unless the parameter's designated type
8931             --  is also class-wide.
8932
8933             if Ekind (Formal_Type) = E_Anonymous_Access_Type
8934               and then not Designates_From_With_Type (Formal_Type)
8935               and then Is_Class_Wide_Default (Default)
8936               and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
8937             then
8938                Error_Msg_N
8939                  ("access to class-wide expression not allowed here", Default);
8940             end if;
8941
8942             --  Check incorrect use of dynamically tagged expressions
8943
8944             if Is_Tagged_Type (Formal_Type) then
8945                Check_Dynamically_Tagged_Expression
8946                  (Expr        => Default,
8947                   Typ         => Formal_Type,
8948                   Related_Nod => Default);
8949             end if;
8950          end if;
8951
8952          --  Ada 2005 (AI-231): Static checks
8953
8954          if Ada_Version >= Ada_2005
8955            and then Is_Access_Type (Etype (Formal))
8956            and then Can_Never_Be_Null (Etype (Formal))
8957          then
8958             Null_Exclusion_Static_Checks (Param_Spec);
8959          end if;
8960
8961       <<Continue>>
8962          Next (Param_Spec);
8963       end loop;
8964
8965       --  If this is the formal part of a function specification, analyze the
8966       --  subtype mark in the context where the formals are visible but not
8967       --  yet usable, and may hide outer homographs.
8968
8969       if Nkind (Related_Nod) = N_Function_Specification then
8970          Analyze_Return_Type (Related_Nod);
8971       end if;
8972
8973       --  Now set the kind (mode) of each formal
8974
8975       Param_Spec := First (T);
8976       while Present (Param_Spec) loop
8977          Formal := Defining_Identifier (Param_Spec);
8978          Set_Formal_Mode (Formal);
8979
8980          if Ekind (Formal) = E_In_Parameter then
8981             Set_Default_Value (Formal, Expression (Param_Spec));
8982
8983             if Present (Expression (Param_Spec)) then
8984                Default :=  Expression (Param_Spec);
8985
8986                if Is_Scalar_Type (Etype (Default)) then
8987                   if Nkind
8988                        (Parameter_Type (Param_Spec)) /= N_Access_Definition
8989                   then
8990                      Formal_Type := Entity (Parameter_Type (Param_Spec));
8991
8992                   else
8993                      Formal_Type := Access_Definition
8994                        (Related_Nod, Parameter_Type (Param_Spec));
8995                   end if;
8996
8997                   Apply_Scalar_Range_Check (Default, Formal_Type);
8998                end if;
8999             end if;
9000
9001          elsif Ekind (Formal) = E_Out_Parameter then
9002             Num_Out_Params := Num_Out_Params + 1;
9003
9004             if Num_Out_Params = 1 then
9005                First_Out_Param := Formal;
9006             end if;
9007
9008          elsif Ekind (Formal) = E_In_Out_Parameter then
9009             Num_Out_Params := Num_Out_Params + 1;
9010          end if;
9011
9012          Next (Param_Spec);
9013       end loop;
9014
9015       if Present (First_Out_Param) and then Num_Out_Params = 1 then
9016          Set_Is_Only_Out_Parameter (First_Out_Param);
9017       end if;
9018    end Process_Formals;
9019
9020    ------------------
9021    -- Process_PPCs --
9022    ------------------
9023
9024    procedure Process_PPCs
9025      (N       : Node_Id;
9026       Spec_Id : Entity_Id;
9027       Body_Id : Entity_Id)
9028    is
9029       Loc   : constant Source_Ptr := Sloc (N);
9030       Prag  : Node_Id;
9031       Parms : List_Id;
9032
9033       Designator : Entity_Id;
9034       --  Subprogram designator, set from Spec_Id if present, else Body_Id
9035
9036       Precond : Node_Id := Empty;
9037       --  Set non-Empty if we prepend precondition to the declarations. This
9038       --  is used to hook up inherited preconditions (adding the condition
9039       --  expression with OR ELSE, and adding the message).
9040
9041       Inherited_Precond : Node_Id;
9042       --  Precondition inherited from parent subprogram
9043
9044       Inherited : constant Subprogram_List :=
9045                      Inherited_Subprograms (Spec_Id);
9046       --  List of subprograms inherited by this subprogram
9047
9048       Plist : List_Id := No_List;
9049       --  List of generated postconditions
9050
9051       function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id;
9052       --  Prag contains an analyzed precondition or postcondition pragma. This
9053       --  function copies the pragma, changes it to the corresponding Check
9054       --  pragma and returns the Check pragma as the result. If Pspec is non-
9055       --  empty, this is the case of inheriting a PPC, where we must change
9056       --  references to parameters of the inherited subprogram to point to the
9057       --  corresponding parameters of the current subprogram.
9058
9059       function Invariants_Or_Predicates_Present return Boolean;
9060       --  Determines if any invariants or predicates are present for any OUT
9061       --  or IN OUT parameters of the subprogram, or (for a function) if the
9062       --  return value has an invariant.
9063
9064       --------------
9065       -- Grab_PPC --
9066       --------------
9067
9068       function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id is
9069          Nam : constant Name_Id := Pragma_Name (Prag);
9070          Map : Elist_Id;
9071          CP  : Node_Id;
9072
9073       begin
9074          --  Prepare map if this is the case where we have to map entities of
9075          --  arguments in the overridden subprogram to corresponding entities
9076          --  of the current subprogram.
9077
9078          if No (Pspec) then
9079             Map := No_Elist;
9080
9081          else
9082             declare
9083                PF : Entity_Id;
9084                CF : Entity_Id;
9085
9086             begin
9087                Map := New_Elmt_List;
9088                PF := First_Formal (Pspec);
9089                CF := First_Formal (Designator);
9090                while Present (PF) loop
9091                   Append_Elmt (PF, Map);
9092                   Append_Elmt (CF, Map);
9093                   Next_Formal (PF);
9094                   Next_Formal (CF);
9095                end loop;
9096             end;
9097          end if;
9098
9099          --  Now we can copy the tree, doing any required substitutions
9100
9101          CP := New_Copy_Tree (Prag, Map => Map, New_Scope => Current_Scope);
9102
9103          --  Set Analyzed to false, since we want to reanalyze the check
9104          --  procedure. Note that it is only at the outer level that we
9105          --  do this fiddling, for the spec cases, the already preanalyzed
9106          --  parameters are not affected.
9107
9108          Set_Analyzed (CP, False);
9109
9110          --  We also make sure Comes_From_Source is False for the copy
9111
9112          Set_Comes_From_Source (CP, False);
9113
9114          --  For a postcondition pragma within a generic, preserve the pragma
9115          --  for later expansion.
9116
9117          if Nam = Name_Postcondition
9118            and then not Expander_Active
9119          then
9120             return CP;
9121          end if;
9122
9123          --  Change copy of pragma into corresponding pragma Check
9124
9125          Prepend_To (Pragma_Argument_Associations (CP),
9126            Make_Pragma_Argument_Association (Sloc (Prag),
9127              Expression => Make_Identifier (Loc, Nam)));
9128          Set_Pragma_Identifier (CP, Make_Identifier (Sloc (Prag), Name_Check));
9129
9130          --  If this is inherited case and the current message starts with
9131          --  "failed p", we change it to "failed inherited p...".
9132
9133          if Present (Pspec) then
9134             declare
9135                Msg : constant Node_Id :=
9136                        Last (Pragma_Argument_Associations (CP));
9137
9138             begin
9139                if Chars (Msg) = Name_Message then
9140                   String_To_Name_Buffer (Strval (Expression (Msg)));
9141
9142                   if Name_Buffer (1 .. 8) = "failed p" then
9143                      Insert_Str_In_Name_Buffer ("inherited ", 8);
9144                      Set_Strval
9145                        (Expression (Last (Pragma_Argument_Associations (CP))),
9146                         String_From_Name_Buffer);
9147                   end if;
9148                end if;
9149             end;
9150          end if;
9151
9152          --  Return the check pragma
9153
9154          return CP;
9155       end Grab_PPC;
9156
9157       --------------------------------------
9158       -- Invariants_Or_Predicates_Present --
9159       --------------------------------------
9160
9161       function Invariants_Or_Predicates_Present return Boolean is
9162          Formal : Entity_Id;
9163
9164       begin
9165          --  Check function return result
9166
9167          if Ekind (Designator) /= E_Procedure
9168            and then Has_Invariants (Etype (Designator))
9169          then
9170             return True;
9171          end if;
9172
9173          --  Check parameters
9174
9175          Formal := First_Formal (Designator);
9176          while Present (Formal) loop
9177             if Ekind (Formal) /= E_In_Parameter
9178               and then
9179                 (Has_Invariants (Etype (Formal))
9180                   or else Present (Predicate_Function (Etype (Formal))))
9181             then
9182                return True;
9183             end if;
9184
9185             Next_Formal (Formal);
9186          end loop;
9187
9188          return False;
9189       end Invariants_Or_Predicates_Present;
9190
9191    --  Start of processing for Process_PPCs
9192
9193    begin
9194       --  Capture designator from spec if present, else from body
9195
9196       if Present (Spec_Id) then
9197          Designator := Spec_Id;
9198       else
9199          Designator := Body_Id;
9200       end if;
9201
9202       --  Grab preconditions from spec
9203
9204       if Present (Spec_Id) then
9205
9206          --  Loop through PPC pragmas from spec. Note that preconditions from
9207          --  the body will be analyzed and converted when we scan the body
9208          --  declarations below.
9209
9210          Prag := Spec_PPC_List (Contract (Spec_Id));
9211          while Present (Prag) loop
9212             if Pragma_Name (Prag) = Name_Precondition then
9213
9214                --  For Pre (or Precondition pragma), we simply prepend the
9215                --  pragma to the list of declarations right away so that it
9216                --  will be executed at the start of the procedure. Note that
9217                --  this processing reverses the order of the list, which is
9218                --  what we want since new entries were chained to the head of
9219                --  the list. There can be more than one precondition when we
9220                --  use pragma Precondition.
9221
9222                if not Class_Present (Prag) then
9223                   Prepend (Grab_PPC, Declarations (N));
9224
9225                --  For Pre'Class there can only be one pragma, and we save
9226                --  it in Precond for now. We will add inherited Pre'Class
9227                --  stuff before inserting this pragma in the declarations.
9228                else
9229                   Precond := Grab_PPC;
9230                end if;
9231             end if;
9232
9233             Prag := Next_Pragma (Prag);
9234          end loop;
9235
9236          --  Now deal with inherited preconditions
9237
9238          for J in Inherited'Range loop
9239             Prag := Spec_PPC_List (Contract (Inherited (J)));
9240
9241             while Present (Prag) loop
9242                if Pragma_Name (Prag) = Name_Precondition
9243                  and then Class_Present (Prag)
9244                then
9245                   Inherited_Precond := Grab_PPC (Inherited (J));
9246
9247                   --  No precondition so far, so establish this as the first
9248
9249                   if No (Precond) then
9250                      Precond := Inherited_Precond;
9251
9252                   --  Here we already have a precondition, add inherited one
9253
9254                   else
9255                      --  Add new precondition to old one using OR ELSE
9256
9257                      declare
9258                         New_Expr : constant Node_Id :=
9259                                      Get_Pragma_Arg
9260                                        (Next
9261                                          (First
9262                                            (Pragma_Argument_Associations
9263                                              (Inherited_Precond))));
9264                         Old_Expr : constant Node_Id :=
9265                                      Get_Pragma_Arg
9266                                        (Next
9267                                          (First
9268                                            (Pragma_Argument_Associations
9269                                              (Precond))));
9270
9271                      begin
9272                         if Paren_Count (Old_Expr) = 0 then
9273                            Set_Paren_Count (Old_Expr, 1);
9274                         end if;
9275
9276                         if Paren_Count (New_Expr) = 0 then
9277                            Set_Paren_Count (New_Expr, 1);
9278                         end if;
9279
9280                         Rewrite (Old_Expr,
9281                           Make_Or_Else (Sloc (Old_Expr),
9282                             Left_Opnd  => Relocate_Node (Old_Expr),
9283                             Right_Opnd => New_Expr));
9284                      end;
9285
9286                      --  Add new message in the form:
9287
9288                      --     failed precondition from bla
9289                      --       also failed inherited precondition from bla
9290                      --       ...
9291
9292                      --  Skip this if exception locations are suppressed
9293
9294                      if not Exception_Locations_Suppressed then
9295                         declare
9296                            New_Msg : constant Node_Id :=
9297                                        Get_Pragma_Arg
9298                                          (Last
9299                                             (Pragma_Argument_Associations
9300                                                (Inherited_Precond)));
9301                            Old_Msg : constant Node_Id :=
9302                                        Get_Pragma_Arg
9303                                          (Last
9304                                             (Pragma_Argument_Associations
9305                                                (Precond)));
9306                         begin
9307                            Start_String (Strval (Old_Msg));
9308                            Store_String_Chars (ASCII.LF & "  also ");
9309                            Store_String_Chars (Strval (New_Msg));
9310                            Set_Strval (Old_Msg, End_String);
9311                         end;
9312                      end if;
9313                   end if;
9314                end if;
9315
9316                Prag := Next_Pragma (Prag);
9317             end loop;
9318          end loop;
9319
9320          --  If we have built a precondition for Pre'Class (including any
9321          --  Pre'Class aspects inherited from parent subprograms), then we
9322          --  insert this composite precondition at this stage.
9323
9324          if Present (Precond) then
9325             Prepend (Precond, Declarations (N));
9326          end if;
9327       end if;
9328
9329       --  Build postconditions procedure if needed and prepend the following
9330       --  declaration to the start of the declarations for the subprogram.
9331
9332       --     procedure _postconditions [(_Result : resulttype)] is
9333       --     begin
9334       --        pragma Check (Postcondition, condition [,message]);
9335       --        pragma Check (Postcondition, condition [,message]);
9336       --        ...
9337       --        Invariant_Procedure (_Result) ...
9338       --        Invariant_Procedure (Arg1)
9339       --        ...
9340       --     end;
9341
9342       --  First we deal with the postconditions in the body
9343
9344       if Is_Non_Empty_List (Declarations (N)) then
9345
9346          --  Loop through declarations
9347
9348          Prag := First (Declarations (N));
9349          while Present (Prag) loop
9350             if Nkind (Prag) = N_Pragma then
9351
9352                --  If pragma, capture if enabled postcondition, else ignore
9353
9354                if Pragma_Name (Prag) = Name_Postcondition
9355                  and then Check_Enabled (Name_Postcondition)
9356                then
9357                   if Plist = No_List then
9358                      Plist := Empty_List;
9359                   end if;
9360
9361                   Analyze (Prag);
9362
9363                   --  If expansion is disabled, as in a generic unit, save
9364                   --  pragma for later expansion.
9365
9366                   if not Expander_Active then
9367                      Prepend (Grab_PPC, Declarations (N));
9368                   else
9369                      Append (Grab_PPC, Plist);
9370                   end if;
9371                end if;
9372
9373                Next (Prag);
9374
9375             --  Not a pragma, if comes from source, then end scan
9376
9377             elsif Comes_From_Source (Prag) then
9378                exit;
9379
9380             --  Skip stuff not coming from source
9381
9382             else
9383                Next (Prag);
9384             end if;
9385          end loop;
9386       end if;
9387
9388       --  Now deal with any postconditions from the spec
9389
9390       if Present (Spec_Id) then
9391          Spec_Postconditions : declare
9392             procedure Process_Post_Conditions
9393               (Spec  : Node_Id;
9394                Class : Boolean);
9395             --  This processes the Spec_PPC_List from Spec, processing any
9396             --  postconditions from the list. If Class is True, then only
9397             --  postconditions marked with Class_Present are considered.
9398             --  The caller has checked that Spec_PPC_List is non-Empty.
9399
9400             -----------------------------
9401             -- Process_Post_Conditions --
9402             -----------------------------
9403
9404             procedure Process_Post_Conditions
9405               (Spec  : Node_Id;
9406                Class : Boolean)
9407             is
9408                Pspec : Node_Id;
9409
9410             begin
9411                if Class then
9412                   Pspec := Spec;
9413                else
9414                   Pspec := Empty;
9415                end if;
9416
9417                --  Loop through PPC pragmas from spec
9418
9419                Prag := Spec_PPC_List (Contract (Spec));
9420                loop
9421                   if Pragma_Name (Prag) = Name_Postcondition
9422                     and then (not Class or else Class_Present (Prag))
9423                   then
9424                      if Plist = No_List then
9425                         Plist := Empty_List;
9426                      end if;
9427
9428                      if not Expander_Active then
9429                         Prepend
9430                           (Grab_PPC (Pspec), Declarations (N));
9431                      else
9432                         Append (Grab_PPC (Pspec), Plist);
9433                      end if;
9434                   end if;
9435
9436                   Prag := Next_Pragma (Prag);
9437                   exit when No (Prag);
9438                end loop;
9439             end Process_Post_Conditions;
9440
9441          --  Start of processing for Spec_Postconditions
9442
9443          begin
9444             if Present (Spec_PPC_List (Contract (Spec_Id))) then
9445                Process_Post_Conditions (Spec_Id, Class => False);
9446             end if;
9447
9448             --  Process inherited postconditions
9449
9450             for J in Inherited'Range loop
9451                if Present (Spec_PPC_List (Contract (Inherited (J)))) then
9452                   Process_Post_Conditions (Inherited (J), Class => True);
9453                end if;
9454             end loop;
9455          end Spec_Postconditions;
9456       end if;
9457
9458       --  If we had any postconditions and expansion is enabled, or if the
9459       --  procedure has invariants, then build the _Postconditions procedure.
9460
9461       if (Present (Plist) or else Invariants_Or_Predicates_Present)
9462         and then Expander_Active
9463       then
9464          if No (Plist) then
9465             Plist := Empty_List;
9466          end if;
9467
9468          --  Special processing for function case
9469
9470          if Ekind (Designator) /= E_Procedure then
9471             declare
9472                Rent : constant Entity_Id :=
9473                         Make_Defining_Identifier (Loc,
9474                           Chars => Name_uResult);
9475                Ftyp : constant Entity_Id := Etype (Designator);
9476
9477             begin
9478                Set_Etype (Rent, Ftyp);
9479
9480                --  Add argument for return
9481
9482                Parms :=
9483                  New_List (
9484                    Make_Parameter_Specification (Loc,
9485                      Parameter_Type      => New_Occurrence_Of (Ftyp, Loc),
9486                      Defining_Identifier => Rent));
9487
9488                --  Add invariant call if returning type with invariants
9489
9490                if Has_Invariants (Etype (Rent))
9491                  and then Present (Invariant_Procedure (Etype (Rent)))
9492                then
9493                   Append_To (Plist,
9494                     Make_Invariant_Call (New_Occurrence_Of (Rent, Loc)));
9495                end if;
9496             end;
9497
9498          --  Procedure rather than a function
9499
9500          else
9501             Parms := No_List;
9502          end if;
9503
9504          --  Add invariant calls and predicate calls for parameters. Note that
9505          --  this is done for functions as well, since in Ada 2012 they can
9506          --  have IN OUT args.
9507
9508          declare
9509             Formal : Entity_Id;
9510             Ftype  : Entity_Id;
9511
9512          begin
9513             Formal := First_Formal (Designator);
9514             while Present (Formal) loop
9515                if Ekind (Formal) /= E_In_Parameter then
9516                   Ftype := Etype (Formal);
9517
9518                   if Has_Invariants (Ftype)
9519                     and then Present (Invariant_Procedure (Ftype))
9520                   then
9521                      Append_To (Plist,
9522                        Make_Invariant_Call
9523                          (New_Occurrence_Of (Formal, Loc)));
9524                   end if;
9525
9526                   if Present (Predicate_Function (Ftype)) then
9527                      Append_To (Plist,
9528                        Make_Predicate_Check
9529                          (Ftype, New_Occurrence_Of (Formal, Loc)));
9530                   end if;
9531                end if;
9532
9533                Next_Formal (Formal);
9534             end loop;
9535          end;
9536
9537          --  Build and insert postcondition procedure
9538
9539          declare
9540             Post_Proc : constant Entity_Id :=
9541                           Make_Defining_Identifier (Loc,
9542                             Chars => Name_uPostconditions);
9543             --  The entity for the _Postconditions procedure
9544
9545          begin
9546             Prepend_To (Declarations (N),
9547               Make_Subprogram_Body (Loc,
9548                 Specification =>
9549                   Make_Procedure_Specification (Loc,
9550                     Defining_Unit_Name => Post_Proc,
9551                     Parameter_Specifications => Parms),
9552
9553                 Declarations => Empty_List,
9554
9555                 Handled_Statement_Sequence =>
9556                   Make_Handled_Sequence_Of_Statements (Loc,
9557                     Statements => Plist)));
9558
9559             Set_Ekind (Post_Proc, E_Procedure);
9560             Set_Is_Postcondition_Proc (Post_Proc);
9561
9562             --  If this is a procedure, set the Postcondition_Proc attribute on
9563             --  the proper defining entity for the subprogram.
9564
9565             if Ekind (Designator) = E_Procedure then
9566                Set_Postcondition_Proc (Designator, Post_Proc);
9567             end if;
9568          end;
9569
9570          Set_Has_Postconditions (Designator);
9571       end if;
9572    end Process_PPCs;
9573
9574    ----------------------------
9575    -- Reference_Body_Formals --
9576    ----------------------------
9577
9578    procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is
9579       Fs : Entity_Id;
9580       Fb : Entity_Id;
9581
9582    begin
9583       if Error_Posted (Spec) then
9584          return;
9585       end if;
9586
9587       --  Iterate over both lists. They may be of different lengths if the two
9588       --  specs are not conformant.
9589
9590       Fs := First_Formal (Spec);
9591       Fb := First_Formal (Bod);
9592       while Present (Fs) and then Present (Fb) loop
9593          Generate_Reference (Fs, Fb, 'b');
9594
9595          if Style_Check then
9596             Style.Check_Identifier (Fb, Fs);
9597          end if;
9598
9599          Set_Spec_Entity (Fb, Fs);
9600          Set_Referenced (Fs, False);
9601          Next_Formal (Fs);
9602          Next_Formal (Fb);
9603       end loop;
9604    end Reference_Body_Formals;
9605
9606    -------------------------
9607    -- Set_Actual_Subtypes --
9608    -------------------------
9609
9610    procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
9611       Decl           : Node_Id;
9612       Formal         : Entity_Id;
9613       T              : Entity_Id;
9614       First_Stmt     : Node_Id := Empty;
9615       AS_Needed      : Boolean;
9616
9617    begin
9618       --  If this is an empty initialization procedure, no need to create
9619       --  actual subtypes (small optimization).
9620
9621       if Ekind (Subp) = E_Procedure
9622         and then Is_Null_Init_Proc (Subp)
9623       then
9624          return;
9625       end if;
9626
9627       Formal := First_Formal (Subp);
9628       while Present (Formal) loop
9629          T := Etype (Formal);
9630
9631          --  We never need an actual subtype for a constrained formal
9632
9633          if Is_Constrained (T) then
9634             AS_Needed := False;
9635
9636          --  If we have unknown discriminants, then we do not need an actual
9637          --  subtype, or more accurately we cannot figure it out! Note that
9638          --  all class-wide types have unknown discriminants.
9639
9640          elsif Has_Unknown_Discriminants (T) then
9641             AS_Needed := False;
9642
9643          --  At this stage we have an unconstrained type that may need an
9644          --  actual subtype. For sure the actual subtype is needed if we have
9645          --  an unconstrained array type.
9646
9647          elsif Is_Array_Type (T) then
9648             AS_Needed := True;
9649
9650          --  The only other case needing an actual subtype is an unconstrained
9651          --  record type which is an IN parameter (we cannot generate actual
9652          --  subtypes for the OUT or IN OUT case, since an assignment can
9653          --  change the discriminant values. However we exclude the case of
9654          --  initialization procedures, since discriminants are handled very
9655          --  specially in this context, see the section entitled "Handling of
9656          --  Discriminants" in Einfo.
9657
9658          --  We also exclude the case of Discrim_SO_Functions (functions used
9659          --  in front end layout mode for size/offset values), since in such
9660          --  functions only discriminants are referenced, and not only are such
9661          --  subtypes not needed, but they cannot always be generated, because
9662          --  of order of elaboration issues.
9663
9664          elsif Is_Record_Type (T)
9665            and then Ekind (Formal) = E_In_Parameter
9666            and then Chars (Formal) /= Name_uInit
9667            and then not Is_Unchecked_Union (T)
9668            and then not Is_Discrim_SO_Function (Subp)
9669          then
9670             AS_Needed := True;
9671
9672          --  All other cases do not need an actual subtype
9673
9674          else
9675             AS_Needed := False;
9676          end if;
9677
9678          --  Generate actual subtypes for unconstrained arrays and
9679          --  unconstrained discriminated records.
9680
9681          if AS_Needed then
9682             if Nkind (N) = N_Accept_Statement then
9683
9684                --  If expansion is active, The formal is replaced by a local
9685                --  variable that renames the corresponding entry of the
9686                --  parameter block, and it is this local variable that may
9687                --  require an actual subtype.
9688
9689                if Expander_Active then
9690                   Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
9691                else
9692                   Decl := Build_Actual_Subtype (T, Formal);
9693                end if;
9694
9695                if Present (Handled_Statement_Sequence (N)) then
9696                   First_Stmt :=
9697                     First (Statements (Handled_Statement_Sequence (N)));
9698                   Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
9699                   Mark_Rewrite_Insertion (Decl);
9700                else
9701                   --  If the accept statement has no body, there will be no
9702                   --  reference to the actuals, so no need to compute actual
9703                   --  subtypes.
9704
9705                   return;
9706                end if;
9707
9708             else
9709                Decl := Build_Actual_Subtype (T, Formal);
9710                Prepend (Decl, Declarations (N));
9711                Mark_Rewrite_Insertion (Decl);
9712             end if;
9713
9714             --  The declaration uses the bounds of an existing object, and
9715             --  therefore needs no constraint checks.
9716
9717             Analyze (Decl, Suppress => All_Checks);
9718
9719             --  We need to freeze manually the generated type when it is
9720             --  inserted anywhere else than in a declarative part.
9721
9722             if Present (First_Stmt) then
9723                Insert_List_Before_And_Analyze (First_Stmt,
9724                  Freeze_Entity (Defining_Identifier (Decl), N));
9725             end if;
9726
9727             if Nkind (N) = N_Accept_Statement
9728               and then Expander_Active
9729             then
9730                Set_Actual_Subtype (Renamed_Object (Formal),
9731                  Defining_Identifier (Decl));
9732             else
9733                Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
9734             end if;
9735          end if;
9736
9737          Next_Formal (Formal);
9738       end loop;
9739    end Set_Actual_Subtypes;
9740
9741    ---------------------
9742    -- Set_Formal_Mode --
9743    ---------------------
9744
9745    procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
9746       Spec : constant Node_Id := Parent (Formal_Id);
9747
9748    begin
9749       --  Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
9750       --  since we ensure that corresponding actuals are always valid at the
9751       --  point of the call.
9752
9753       if Out_Present (Spec) then
9754          if Ekind (Scope (Formal_Id)) = E_Function
9755            or else Ekind (Scope (Formal_Id)) = E_Generic_Function
9756          then
9757             --  [IN] OUT parameters allowed for functions in Ada 2012
9758
9759             if Ada_Version >= Ada_2012 then
9760                if In_Present (Spec) then
9761                   Set_Ekind (Formal_Id, E_In_Out_Parameter);
9762                else
9763                   Set_Ekind (Formal_Id, E_Out_Parameter);
9764                end if;
9765
9766             --  But not in earlier versions of Ada
9767
9768             else
9769                Error_Msg_N ("functions can only have IN parameters", Spec);
9770                Set_Ekind (Formal_Id, E_In_Parameter);
9771             end if;
9772
9773          elsif In_Present (Spec) then
9774             Set_Ekind (Formal_Id, E_In_Out_Parameter);
9775
9776          else
9777             Set_Ekind               (Formal_Id, E_Out_Parameter);
9778             Set_Never_Set_In_Source (Formal_Id, True);
9779             Set_Is_True_Constant    (Formal_Id, False);
9780             Set_Current_Value       (Formal_Id, Empty);
9781          end if;
9782
9783       else
9784          Set_Ekind (Formal_Id, E_In_Parameter);
9785       end if;
9786
9787       --  Set Is_Known_Non_Null for access parameters since the language
9788       --  guarantees that access parameters are always non-null. We also set
9789       --  Can_Never_Be_Null, since there is no way to change the value.
9790
9791       if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
9792
9793          --  Ada 2005 (AI-231): In Ada95, access parameters are always non-
9794          --  null; In Ada 2005, only if then null_exclusion is explicit.
9795
9796          if Ada_Version < Ada_2005
9797            or else Can_Never_Be_Null (Etype (Formal_Id))
9798          then
9799             Set_Is_Known_Non_Null (Formal_Id);
9800             Set_Can_Never_Be_Null (Formal_Id);
9801          end if;
9802
9803       --  Ada 2005 (AI-231): Null-exclusion access subtype
9804
9805       elsif Is_Access_Type (Etype (Formal_Id))
9806         and then Can_Never_Be_Null (Etype (Formal_Id))
9807       then
9808          Set_Is_Known_Non_Null (Formal_Id);
9809       end if;
9810
9811       Set_Mechanism (Formal_Id, Default_Mechanism);
9812       Set_Formal_Validity (Formal_Id);
9813    end Set_Formal_Mode;
9814
9815    -------------------------
9816    -- Set_Formal_Validity --
9817    -------------------------
9818
9819    procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
9820    begin
9821       --  If no validity checking, then we cannot assume anything about the
9822       --  validity of parameters, since we do not know there is any checking
9823       --  of the validity on the call side.
9824
9825       if not Validity_Checks_On then
9826          return;
9827
9828       --  If validity checking for parameters is enabled, this means we are
9829       --  not supposed to make any assumptions about argument values.
9830
9831       elsif Validity_Check_Parameters then
9832          return;
9833
9834       --  If we are checking in parameters, we will assume that the caller is
9835       --  also checking parameters, so we can assume the parameter is valid.
9836
9837       elsif Ekind (Formal_Id) = E_In_Parameter
9838         and then Validity_Check_In_Params
9839       then
9840          Set_Is_Known_Valid (Formal_Id, True);
9841
9842       --  Similar treatment for IN OUT parameters
9843
9844       elsif Ekind (Formal_Id) = E_In_Out_Parameter
9845         and then Validity_Check_In_Out_Params
9846       then
9847          Set_Is_Known_Valid (Formal_Id, True);
9848       end if;
9849    end Set_Formal_Validity;
9850
9851    ------------------------
9852    -- Subtype_Conformant --
9853    ------------------------
9854
9855    function Subtype_Conformant
9856      (New_Id                   : Entity_Id;
9857       Old_Id                   : Entity_Id;
9858       Skip_Controlling_Formals : Boolean := False) return Boolean
9859    is
9860       Result : Boolean;
9861    begin
9862       Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result,
9863         Skip_Controlling_Formals => Skip_Controlling_Formals);
9864       return Result;
9865    end Subtype_Conformant;
9866
9867    ---------------------
9868    -- Type_Conformant --
9869    ---------------------
9870
9871    function Type_Conformant
9872      (New_Id                   : Entity_Id;
9873       Old_Id                   : Entity_Id;
9874       Skip_Controlling_Formals : Boolean := False) return Boolean
9875    is
9876       Result : Boolean;
9877    begin
9878       May_Hide_Profile := False;
9879
9880       Check_Conformance
9881         (New_Id, Old_Id, Type_Conformant, False, Result,
9882          Skip_Controlling_Formals => Skip_Controlling_Formals);
9883       return Result;
9884    end Type_Conformant;
9885
9886    -------------------------------
9887    -- Valid_Operator_Definition --
9888    -------------------------------
9889
9890    procedure Valid_Operator_Definition (Designator : Entity_Id) is
9891       N    : Integer := 0;
9892       F    : Entity_Id;
9893       Id   : constant Name_Id := Chars (Designator);
9894       N_OK : Boolean;
9895
9896    begin
9897       F := First_Formal (Designator);
9898       while Present (F) loop
9899          N := N + 1;
9900
9901          if Present (Default_Value (F)) then
9902             Error_Msg_N
9903               ("default values not allowed for operator parameters",
9904                Parent (F));
9905          end if;
9906
9907          Next_Formal (F);
9908       end loop;
9909
9910       --  Verify that user-defined operators have proper number of arguments
9911       --  First case of operators which can only be unary
9912
9913       if Id = Name_Op_Not
9914         or else Id = Name_Op_Abs
9915       then
9916          N_OK := (N = 1);
9917
9918       --  Case of operators which can be unary or binary
9919
9920       elsif Id = Name_Op_Add
9921         or Id = Name_Op_Subtract
9922       then
9923          N_OK := (N in 1 .. 2);
9924
9925       --  All other operators can only be binary
9926
9927       else
9928          N_OK := (N = 2);
9929       end if;
9930
9931       if not N_OK then
9932          Error_Msg_N
9933            ("incorrect number of arguments for operator", Designator);
9934       end if;
9935
9936       if Id = Name_Op_Ne
9937         and then Base_Type (Etype (Designator)) = Standard_Boolean
9938         and then not Is_Intrinsic_Subprogram (Designator)
9939       then
9940          Error_Msg_N
9941             ("explicit definition of inequality not allowed", Designator);
9942       end if;
9943    end Valid_Operator_Definition;
9944
9945 end Sem_Ch6;