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