gcc/ada/sem_ch6.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C H 6                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Expander; use Expander;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Tss;  use Exp_Tss;
  36 with Fname;    use Fname;
  37 with Freeze;   use Freeze;
  38 with Itypes;   use Itypes;
  39 with Lib.Xref; use Lib.Xref;
  40 with Namet;    use Namet;
  41 with Lib;      use Lib;
  42 with Nlists;   use Nlists;
  43 with Nmake;    use Nmake;
  44 with Opt;      use Opt;
  45 with Output;   use Output;
  46 with Rtsfind;  use Rtsfind;
  47 with Sem;      use Sem;
  48 with Sem_Cat;  use Sem_Cat;
  49 with Sem_Ch3;  use Sem_Ch3;
  50 with Sem_Ch4;  use Sem_Ch4;
  51 with Sem_Ch5;  use Sem_Ch5;
  52 with Sem_Ch8;  use Sem_Ch8;
  53 with Sem_Ch10; use Sem_Ch10;
  54 with Sem_Ch12; use Sem_Ch12;
  55 with Sem_Disp; use Sem_Disp;
  56 with Sem_Dist; use Sem_Dist;
  57 with Sem_Elim; use Sem_Elim;
  58 with Sem_Eval; use Sem_Eval;
  59 with Sem_Mech; use Sem_Mech;
  60 with Sem_Prag; use Sem_Prag;
  61 with Sem_Res;  use Sem_Res;
  62 with Sem_Util; use Sem_Util;
  63 with Sem_Type; use Sem_Type;
  64 with Sem_Warn; use Sem_Warn;
  65 with Sinput;   use Sinput;
  66 with Stand;    use Stand;
  67 with Sinfo;    use Sinfo;
  68 with Sinfo.CN; use Sinfo.CN;
  69 with Snames;   use Snames;
  70 with Stringt;  use Stringt;
  71 with Style;
  72 with Stylesw;  use Stylesw;
  73 with Tbuild;   use Tbuild;
  74 with Uintp;    use Uintp;
  75 with Urealp;   use Urealp;
  76 with Validsw;  use Validsw;
  77
  78 package body Sem_Ch6 is
  79
  80    --  The following flag is used to indicate that two formals in two
  81    --  subprograms being checked for conformance differ only in that one is
  82    --  an access parameter while the other is of a general access type with
  83    --  the same designated type. In this case, if the rest of the signatures
  84    --  match, a call to either subprogram may be ambiguous, which is worth
  85    --  a warning. The flag is set in Compatible_Types, and the warning emitted
  86    --  in New_Overloaded_Entity.
  87
  88    May_Hide_Profile : Boolean := False;
  89
  90    -----------------------
  91    -- Local Subprograms --
  92    -----------------------
  93
  94    procedure Analyze_Return_Type (N : Node_Id);
  95    --  Subsidiary to Process_Formals: analyze subtype mark in function
  96    --  specification, in a context where the formals are visible and hide
  97    --  outer homographs.
  98
  99    procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
 100    --  Analyze a generic subprogram body. N is the body to be analyzed, and
 101    --  Gen_Id is the defining entity Id for the corresponding spec.
 102
 103    procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
 104    --  If a subprogram has pragma Inline and inlining is active, use generic
 105    --  machinery to build an unexpanded body for the subprogram. This body is
 106    --  subsequenty used for inline expansions at call sites. If subprogram can
 107    --  be inlined (depending on size and nature of local declarations) this
 108    --  function returns true. Otherwise subprogram body is treated normally.
 109    --  If proper warnings are enabled and the subprogram contains a construct
 110    --  that cannot be inlined, the offending construct is flagged accordingly.
 111
 112    type Conformance_Type is
 113      (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
 114    --  Conformance type used for following call, meaning matches the
 115    --  RM definitions of the corresponding terms.
 116
 117    procedure Check_Conformance
 118      (New_Id                   : Entity_Id;
 119       Old_Id                   : Entity_Id;
 120       Ctype                    : Conformance_Type;
 121       Errmsg                   : Boolean;
 122       Conforms                 : out Boolean;
 123       Err_Loc                  : Node_Id := Empty;
 124       Get_Inst                 : Boolean := False;
 125       Skip_Controlling_Formals : Boolean := False);
 126    --  Given two entities, this procedure checks that the profiles associated
 127    --  with these entities meet the conformance criterion given by the third
 128    --  parameter. If they conform, Conforms is set True and control returns
 129    --  to the caller. If they do not conform, Conforms is set to False, and
 130    --  in addition, if Errmsg is True on the call, proper messages are output
 131    --  to complain about the conformance failure. If Err_Loc is non_Empty
 132    --  the error messages are placed on Err_Loc, if Err_Loc is empty, then
 133    --  error messages are placed on the appropriate part of the construct
 134    --  denoted by New_Id. If Get_Inst is true, then this is a mode conformance
 135    --  against a formal access-to-subprogram type so Get_Instance_Of must
 136    --  be called.
 137
 138    procedure Check_Overriding_Indicator
 139      (Subp          : Entity_Id;
 140       Does_Override : Boolean);
 141    --  Verify the consistency of an overriding_indicator given for subprogram
 142    --  declaration, body, renaming, or instantiation. The flag Does_Override
 143    --  is set if the scope into which we are introducing the subprogram
 144    --  contains a type-conformant subprogram that becomes hidden by the new
 145    --  subprogram.
 146
 147    procedure Check_Subprogram_Order (N : Node_Id);
 148    --  N is the N_Subprogram_Body node for a subprogram. This routine applies
 149    --  the alpha ordering rule for N if this ordering requirement applicable.
 150
 151    procedure Check_Returns
 152      (HSS  : Node_Id;
 153       Mode : Character;
 154       Err  : out Boolean;
 155       Proc : Entity_Id := Empty);
 156    --  Called to check for missing return statements in a function body, or for
 157    --  returns present in a procedure body which has No_Return set. L is the
 158    --  handled statement sequence for the subprogram body. This procedure
 159    --  checks all flow paths to make sure they either have return (Mode = 'F',
 160    --  used for functions) or do not have a return (Mode = 'P', used for
 161    --  No_Return procedures). The flag Err is set if there are any control
 162    --  paths not explicitly terminated by a return in the function case, and is
 163    --  True otherwise. Proc is the entity for the procedure case and is used
 164    --  in posting the warning message.
 165
 166    function Conforming_Types
 167      (T1       : Entity_Id;
 168       T2       : Entity_Id;
 169       Ctype    : Conformance_Type;
 170       Get_Inst : Boolean := False) return Boolean;
 171    --  Check that two formal parameter types conform, checking both for
 172    --  equality of base types, and where required statically matching
 173    --  subtypes, depending on the setting of Ctype.
 174
 175    procedure Enter_Overloaded_Entity (S : Entity_Id);
 176    --  This procedure makes S, a new overloaded entity, into the first visible
 177    --  entity with that name.
 178
 179    procedure Install_Entity (E : Entity_Id);
 180    --  Make single entity visible. Used for generic formals as well
 181
 182    procedure Install_Formals (Id : Entity_Id);
 183    --  On entry to a subprogram body, make the formals visible. Note that
 184    --  simply placing the subprogram on the scope stack is not sufficient:
 185    --  the formals must become the current entities for their names.
 186
 187    function Is_Non_Overriding_Operation
 188      (Prev_E : Entity_Id;
 189       New_E  : Entity_Id) return Boolean;
 190    --  Enforce the rule given in 12.3(18): a private operation in an instance
 191    --  overrides an inherited operation only if the corresponding operation
 192    --  was overriding in the generic. This can happen for primitive operations
 193    --  of types derived (in the generic unit) from formal private or formal
 194    --  derived types.
 195
 196    procedure Make_Inequality_Operator (S : Entity_Id);
 197    --  Create the declaration for an inequality operator that is implicitly
 198    --  created by a user-defined equality operator that yields a boolean.
 199
 200    procedure May_Need_Actuals (Fun : Entity_Id);
 201    --  Flag functions that can be called without parameters, i.e. those that
 202    --  have no parameters, or those for which defaults exist for all parameters
 203
 204    procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);
 205    --  If there is a separate spec for a subprogram or generic subprogram, the
 206    --  formals of the body are treated as references to the corresponding
 207    --  formals of the spec. This reference does not count as an actual use of
 208    --  the formal, in order to diagnose formals that are unused in the body.
 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
 213    --  on 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       Designator : constant Entity_Id :=
 221                      Analyze_Subprogram_Specification (Specification (N));
 222       Scop       : constant Entity_Id := Current_Scope;
 223
 224    begin
 225       Generate_Definition (Designator);
 226       Set_Is_Abstract (Designator);
 227       New_Overloaded_Entity (Designator);
 228       Check_Delayed_Subprogram (Designator);
 229
 230       Set_Categorization_From_Scope (Designator, Scop);
 231
 232       if Ekind (Scope (Designator)) = E_Protected_Type then
 233          Error_Msg_N
 234            ("abstract subprogram not allowed in protected type", N);
 235       end if;
 236
 237       Generate_Reference_To_Formals (Designator);
 238    end Analyze_Abstract_Subprogram_Declaration;
 239
 240    ----------------------------
 241    -- Analyze_Function_Call  --
 242    ----------------------------
 243
 244    procedure Analyze_Function_Call (N : Node_Id) is
 245       P      : constant Node_Id := Name (N);
 246       L      : constant List_Id := Parameter_Associations (N);
 247       Actual : Node_Id;
 248
 249    begin
 250       Analyze (P);
 251
 252       --  A call of the form A.B (X) may be an Ada05 call, which is rewritten
 253       --  as B (A, X). If the rewriting is successful, the call has been
 254       --  analyzed and we just return.
 255
 256       if Nkind (P) = N_Selected_Component
 257         and then Name (N) /= P
 258         and then Is_Rewrite_Substitution (N)
 259         and then Present (Etype (N))
 260       then
 261          return;
 262       end if;
 263
 264       --  If error analyzing name, then set Any_Type as result type and return
 265
 266       if Etype (P) = Any_Type then
 267          Set_Etype (N, Any_Type);
 268          return;
 269       end if;
 270
 271       --  Otherwise analyze the parameters
 272
 273       if Present (L) then
 274          Actual := First (L);
 275          while Present (Actual) loop
 276             Analyze (Actual);
 277             Check_Parameterless_Call (Actual);
 278             Next (Actual);
 279          end loop;
 280       end if;
 281
 282       Analyze_Call (N);
 283    end Analyze_Function_Call;
 284
 285    -------------------------------------
 286    -- Analyze_Generic_Subprogram_Body --
 287    -------------------------------------
 288
 289    procedure Analyze_Generic_Subprogram_Body
 290      (N      : Node_Id;
 291       Gen_Id : Entity_Id)
 292    is
 293       Gen_Decl : constant Node_Id     := Unit_Declaration_Node (Gen_Id);
 294       Kind     : constant Entity_Kind := Ekind (Gen_Id);
 295       Body_Id  : Entity_Id;
 296       New_N    : Node_Id;
 297       Spec     : Node_Id;
 298
 299    begin
 300       --  Copy body and disable expansion while analyzing the generic For a
 301       --  stub, do not copy the stub (which would load the proper body), this
 302       --  will be done when the proper body is analyzed.
 303
 304       if Nkind (N) /= N_Subprogram_Body_Stub then
 305          New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
 306          Rewrite (N, New_N);
 307          Start_Generic;
 308       end if;
 309
 310       Spec := Specification (N);
 311
 312       --  Within the body of the generic, the subprogram is callable, and
 313       --  behaves like the corresponding non-generic unit.
 314
 315       Body_Id := Defining_Entity (Spec);
 316
 317       if Kind = E_Generic_Procedure
 318         and then Nkind (Spec) /= N_Procedure_Specification
 319       then
 320          Error_Msg_N ("invalid body for generic procedure ", Body_Id);
 321          return;
 322
 323       elsif Kind = E_Generic_Function
 324         and then Nkind (Spec) /= N_Function_Specification
 325       then
 326          Error_Msg_N ("invalid body for generic function ", Body_Id);
 327          return;
 328       end if;
 329
 330       Set_Corresponding_Body (Gen_Decl, Body_Id);
 331
 332       if Has_Completion (Gen_Id)
 333         and then Nkind (Parent (N)) /= N_Subunit
 334       then
 335          Error_Msg_N ("duplicate generic body", N);
 336          return;
 337       else
 338          Set_Has_Completion (Gen_Id);
 339       end if;
 340
 341       if Nkind (N) = N_Subprogram_Body_Stub then
 342          Set_Ekind (Defining_Entity (Specification (N)), Kind);
 343       else
 344          Set_Corresponding_Spec (N, Gen_Id);
 345       end if;
 346
 347       if Nkind (Parent (N)) = N_Compilation_Unit then
 348          Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
 349       end if;
 350
 351       --  Make generic parameters immediately visible in the body. They are
 352       --  needed to process the formals declarations. Then make the formals
 353       --  visible in a separate step.
 354
 355       New_Scope (Gen_Id);
 356
 357       declare
 358          E         : Entity_Id;
 359          First_Ent : Entity_Id;
 360
 361       begin
 362          First_Ent := First_Entity (Gen_Id);
 363
 364          E := First_Ent;
 365          while Present (E) and then not Is_Formal (E) loop
 366             Install_Entity (E);
 367             Next_Entity (E);
 368          end loop;
 369
 370          Set_Use (Generic_Formal_Declarations (Gen_Decl));
 371
 372          --  Now generic formals are visible, and the specification can be
 373          --  analyzed, for subsequent conformance check.
 374
 375          Body_Id := Analyze_Subprogram_Specification (Spec);
 376
 377          --  Make formal parameters visible
 378
 379          if Present (E) then
 380
 381             --  E is the first formal parameter, we loop through the formals
 382             --  installing them so that they will be visible.
 383
 384             Set_First_Entity (Gen_Id, E);
 385             while Present (E) loop
 386                Install_Entity (E);
 387                Next_Formal (E);
 388             end loop;
 389          end if;
 390
 391          --  Visible generic entity is callable within its own body
 392
 393          Set_Ekind (Gen_Id, Ekind (Body_Id));
 394          Set_Ekind (Body_Id, E_Subprogram_Body);
 395          Set_Convention (Body_Id, Convention (Gen_Id));
 396          Set_Scope (Body_Id, Scope (Gen_Id));
 397          Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
 398
 399          if Nkind (N) = N_Subprogram_Body_Stub then
 400
 401             --  No body to analyze, so restore state of generic unit
 402
 403             Set_Ekind (Gen_Id, Kind);
 404             Set_Ekind (Body_Id, Kind);
 405
 406             if Present (First_Ent) then
 407                Set_First_Entity (Gen_Id, First_Ent);
 408             end if;
 409
 410             End_Scope;
 411             return;
 412          end if;
 413
 414          --  If this is a compilation unit, it must be made visible explicitly,
 415          --  because the compilation of the declaration, unlike other library
 416          --  unit declarations, does not. If it is not a unit, the following
 417          --  is redundant but harmless.
 418
 419          Set_Is_Immediately_Visible (Gen_Id);
 420          Reference_Body_Formals (Gen_Id, Body_Id);
 421
 422          Set_Actual_Subtypes (N, Current_Scope);
 423          Analyze_Declarations (Declarations (N));
 424          Check_Completion;
 425          Analyze (Handled_Statement_Sequence (N));
 426
 427          Save_Global_References (Original_Node (N));
 428
 429          --  Prior to exiting the scope, include generic formals again (if any
 430          --  are present) in the set of local entities.
 431
 432          if Present (First_Ent) then
 433             Set_First_Entity (Gen_Id, First_Ent);
 434          end if;
 435
 436          Check_References (Gen_Id);
 437       end;
 438
 439       Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
 440       End_Scope;
 441       Check_Subprogram_Order (N);
 442
 443       --  Outside of its body, unit is generic again
 444
 445       Set_Ekind (Gen_Id, Kind);
 446       Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
 447       Style.Check_Identifier (Body_Id, Gen_Id);
 448       End_Generic;
 449    end Analyze_Generic_Subprogram_Body;
 450
 451    -----------------------------
 452    -- Analyze_Operator_Symbol --
 453    -----------------------------
 454
 455    --  An operator symbol such as "+" or "and" may appear in context where the
 456    --  literal denotes an entity name, such as "+"(x, y) or in context when it
 457    --  is just a string, as in (conjunction = "or"). In these cases the parser
 458    --  generates this node, and the semantics does the disambiguation. Other
 459    --  such case are actuals in an instantiation, the generic unit in an
 460    --  instantiation, and pragma arguments.
 461
 462    procedure Analyze_Operator_Symbol (N : Node_Id) is
 463       Par : constant Node_Id := Parent (N);
 464
 465    begin
 466       if        (Nkind (Par) = N_Function_Call and then N = Name (Par))
 467         or else  Nkind (Par) = N_Function_Instantiation
 468         or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
 469         or else (Nkind (Par) = N_Pragma_Argument_Association
 470                    and then not Is_Pragma_String_Literal (Par))
 471         or else  Nkind (Par) = N_Subprogram_Renaming_Declaration
 472         or else  (Nkind (Par) = N_Attribute_Reference
 473                    and then Attribute_Name (Par) /= Name_Value)
 474       then
 475          Find_Direct_Name (N);
 476
 477       else
 478          Change_Operator_Symbol_To_String_Literal (N);
 479          Analyze (N);
 480       end if;
 481    end Analyze_Operator_Symbol;
 482
 483    -----------------------------------
 484    -- Analyze_Parameter_Association --
 485    -----------------------------------
 486
 487    procedure Analyze_Parameter_Association (N : Node_Id) is
 488    begin
 489       Analyze (Explicit_Actual_Parameter (N));
 490    end Analyze_Parameter_Association;
 491
 492    ----------------------------
 493    -- Analyze_Procedure_Call --
 494    ----------------------------
 495
 496    procedure Analyze_Procedure_Call (N : Node_Id) is
 497       Loc     : constant Source_Ptr := Sloc (N);
 498       P       : constant Node_Id    := Name (N);
 499       Actuals : constant List_Id    := Parameter_Associations (N);
 500       Actual  : Node_Id;
 501       New_N   : Node_Id;
 502
 503       procedure Analyze_Call_And_Resolve;
 504       --  Do Analyze and Resolve calls for procedure call
 505
 506       ------------------------------
 507       -- Analyze_Call_And_Resolve --
 508       ------------------------------
 509
 510       procedure Analyze_Call_And_Resolve is
 511       begin
 512          if Nkind (N) = N_Procedure_Call_Statement then
 513             Analyze_Call (N);
 514             Resolve (N, Standard_Void_Type);
 515          else
 516             Analyze (N);
 517          end if;
 518       end Analyze_Call_And_Resolve;
 519
 520    --  Start of processing for Analyze_Procedure_Call
 521
 522    begin
 523       --  The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
 524       --  a procedure call or an entry call. The prefix may denote an access
 525       --  to subprogram type, in which case an implicit dereference applies.
 526       --  If the prefix is an indexed component (without implicit defererence)
 527       --  then the construct denotes a call to a member of an entire family.
 528       --  If the prefix is a simple name, it may still denote a call to a
 529       --  parameterless member of an entry family. Resolution of these various
 530       --  interpretations is delicate.
 531
 532       Analyze (P);
 533
 534       --  If this is a call of the form Obj.Op, the call may have been
 535       --  analyzed and possibly rewritten into a block, in which case
 536       --  we are done.
 537
 538       if Analyzed (N) then
 539          return;
 540       end if;
 541
 542       --  If error analyzing prefix, then set Any_Type as result and return
 543
 544       if Etype (P) = Any_Type then
 545          Set_Etype (N, Any_Type);
 546          return;
 547       end if;
 548
 549       --  Otherwise analyze the parameters
 550
 551       if Present (Actuals) then
 552          Actual := First (Actuals);
 553
 554          while Present (Actual) loop
 555             Analyze (Actual);
 556             Check_Parameterless_Call (Actual);
 557             Next (Actual);
 558          end loop;
 559       end if;
 560
 561       --  Special processing for Elab_Spec and Elab_Body calls
 562
 563       if Nkind (P) = N_Attribute_Reference
 564         and then (Attribute_Name (P) = Name_Elab_Spec
 565                    or else Attribute_Name (P) = Name_Elab_Body)
 566       then
 567          if Present (Actuals) then
 568             Error_Msg_N
 569               ("no parameters allowed for this call", First (Actuals));
 570             return;
 571          end if;
 572
 573          Set_Etype (N, Standard_Void_Type);
 574          Set_Analyzed (N);
 575
 576       elsif Is_Entity_Name (P)
 577         and then Is_Record_Type (Etype (Entity (P)))
 578         and then Remote_AST_I_Dereference (P)
 579       then
 580          return;
 581
 582       elsif Is_Entity_Name (P)
 583         and then Ekind (Entity (P)) /= E_Entry_Family
 584       then
 585          if Is_Access_Type (Etype (P))
 586            and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
 587            and then No (Actuals)
 588            and then Comes_From_Source (N)
 589          then
 590             Error_Msg_N ("missing explicit dereference in call", N);
 591          end if;
 592
 593          Analyze_Call_And_Resolve;
 594
 595       --  If the prefix is the simple name of an entry family, this is
 596       --  a parameterless call from within the task body itself.
 597
 598       elsif Is_Entity_Name (P)
 599         and then Nkind (P) = N_Identifier
 600         and then Ekind (Entity (P)) = E_Entry_Family
 601         and then Present (Actuals)
 602         and then No (Next (First (Actuals)))
 603       then
 604          --  Can be call to parameterless entry family. What appears to be the
 605          --  sole argument is in fact the entry index. Rewrite prefix of node
 606          --  accordingly. Source representation is unchanged by this
 607          --  transformation.
 608
 609          New_N :=
 610            Make_Indexed_Component (Loc,
 611              Prefix =>
 612                Make_Selected_Component (Loc,
 613                  Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
 614                  Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
 615              Expressions => Actuals);
 616          Set_Name (N, New_N);
 617          Set_Etype (New_N, Standard_Void_Type);
 618          Set_Parameter_Associations (N, No_List);
 619          Analyze_Call_And_Resolve;
 620
 621       elsif Nkind (P) = N_Explicit_Dereference then
 622          if Ekind (Etype (P)) = E_Subprogram_Type then
 623             Analyze_Call_And_Resolve;
 624          else
 625             Error_Msg_N ("expect access to procedure in call", P);
 626          end if;
 627
 628       --  The name can be a selected component or an indexed component that
 629       --  yields an access to subprogram. Such a prefix is legal if the call
 630       --  has parameter associations.
 631
 632       elsif Is_Access_Type (Etype (P))
 633         and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
 634       then
 635          if Present (Actuals) then
 636             Analyze_Call_And_Resolve;
 637          else
 638             Error_Msg_N ("missing explicit dereference in call ", N);
 639          end if;
 640
 641       --  If not an access to subprogram, then the prefix must resolve to the
 642       --  name of an entry, entry family, or protected operation.
 643
 644       --  For the case of a simple entry call, P is a selected component where
 645       --  the prefix is the task and the selector name is the entry. A call to
 646       --  a protected procedure will have the same syntax. If the protected
 647       --  object contains overloaded operations, the entity may appear as a
 648       --  function, the context will select the operation whose type is Void.
 649
 650       elsif Nkind (P) = N_Selected_Component
 651         and then (Ekind (Entity (Selector_Name (P))) = E_Entry
 652                     or else
 653                   Ekind (Entity (Selector_Name (P))) = E_Procedure
 654                     or else
 655                   Ekind (Entity (Selector_Name (P))) = E_Function)
 656       then
 657          Analyze_Call_And_Resolve;
 658
 659       elsif Nkind (P) = N_Selected_Component
 660         and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
 661         and then Present (Actuals)
 662         and then No (Next (First (Actuals)))
 663       then
 664          --  Can be call to parameterless entry family. What appears to be the
 665          --  sole argument is in fact the entry index. Rewrite prefix of node
 666          --  accordingly. Source representation is unchanged by this
 667          --  transformation.
 668
 669          New_N :=
 670            Make_Indexed_Component (Loc,
 671              Prefix => New_Copy (P),
 672              Expressions => Actuals);
 673          Set_Name (N, New_N);
 674          Set_Etype (New_N, Standard_Void_Type);
 675          Set_Parameter_Associations (N, No_List);
 676          Analyze_Call_And_Resolve;
 677
 678       --  For the case of a reference to an element of an entry family, P is
 679       --  an indexed component whose prefix is a selected component (task and
 680       --  entry family), and whose index is the entry family index.
 681
 682       elsif Nkind (P) = N_Indexed_Component
 683         and then Nkind (Prefix (P)) = N_Selected_Component
 684         and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
 685       then
 686          Analyze_Call_And_Resolve;
 687
 688       --  If the prefix is the name of an entry family, it is a call from
 689       --  within the task body itself.
 690
 691       elsif Nkind (P) = N_Indexed_Component
 692         and then Nkind (Prefix (P)) = N_Identifier
 693         and then Ekind (Entity (Prefix (P))) = E_Entry_Family
 694       then
 695          New_N :=
 696            Make_Selected_Component (Loc,
 697              Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
 698              Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
 699          Rewrite (Prefix (P), New_N);
 700          Analyze (P);
 701          Analyze_Call_And_Resolve;
 702
 703       --  Anything else is an error
 704
 705       else
 706          Error_Msg_N ("invalid procedure or entry call", N);
 707       end if;
 708    end Analyze_Procedure_Call;
 709
 710    ------------------------------
 711    -- Analyze_Return_Statement --
 712    ------------------------------
 713
 714    procedure Analyze_Return_Statement (N : Node_Id) is
 715       Loc      : constant Source_Ptr := Sloc (N);
 716       Expr     : Node_Id;
 717       Scope_Id : Entity_Id;
 718       Kind     : Entity_Kind;
 719       R_Type   : Entity_Id;
 720
 721    begin
 722       --  Find subprogram or accept statement enclosing the return statement
 723
 724       Scope_Id := Empty;
 725       for J in reverse 0 .. Scope_Stack.Last loop
 726          Scope_Id := Scope_Stack.Table (J).Entity;
 727          exit when Ekind (Scope_Id) /= E_Block and then
 728                    Ekind (Scope_Id) /= E_Loop;
 729       end loop;
 730
 731       pragma Assert (Present (Scope_Id));
 732
 733       Kind := Ekind (Scope_Id);
 734       Expr := Expression (N);
 735
 736       if Kind /= E_Function
 737         and then Kind /= E_Generic_Function
 738         and then Kind /= E_Procedure
 739         and then Kind /= E_Generic_Procedure
 740         and then Kind /= E_Entry
 741         and then Kind /= E_Entry_Family
 742       then
 743          Error_Msg_N ("illegal context for return statement", N);
 744
 745       elsif Present (Expr) then
 746          if Kind = E_Function or else Kind = E_Generic_Function then
 747             Set_Return_Present (Scope_Id);
 748             R_Type := Etype (Scope_Id);
 749             Set_Return_Type (N, R_Type);
 750             Analyze_And_Resolve (Expr, R_Type);
 751
 752             --  Ada 2005 (AI-318-02): When the result type is an anonymous
 753             --  access type, apply an implicit conversion of the expression
 754             --  to that type to force appropriate static and run-time
 755             --  accessibility checks.
 756
 757             if Ada_Version >= Ada_05
 758               and then Ekind (R_Type) = E_Anonymous_Access_Type
 759             then
 760                Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
 761                Analyze_And_Resolve (Expr, R_Type);
 762             end if;
 763
 764             if (Is_Class_Wide_Type (Etype (Expr))
 765                  or else Is_Dynamically_Tagged (Expr))
 766               and then not Is_Class_Wide_Type (R_Type)
 767             then
 768                Error_Msg_N
 769                  ("dynamically tagged expression not allowed!", Expr);
 770             end if;
 771
 772             Apply_Constraint_Check (Expr, R_Type);
 773
 774             --  Ada 2005 (AI-318-02): Return-by-reference types have been
 775             --  removed and replaced by anonymous access results. This is
 776             --  an incompatibility with Ada 95. Not clear whether this
 777             --  should be enforced yet or perhaps controllable with a
 778             --  special switch. ???
 779
 780             --  if Ada_Version >= Ada_05
 781             --    and then Is_Limited_Type (R_Type)
 782             --    and then Nkind (Expr) /= N_Aggregate
 783             --    and then Nkind (Expr) /= N_Extension_Aggregate
 784             --    and then Nkind (Expr) /= N_Function_Call
 785             --  then
 786             --     Error_Msg_N
 787             --       ("(Ada 2005) illegal operand for limited return", N);
 788             --  end if;
 789
 790             --  ??? A real run-time accessibility check is needed in cases
 791             --  involving dereferences of access parameters. For now we just
 792             --  check the static cases.
 793
 794             if Is_Return_By_Reference_Type (Etype (Scope_Id))
 795               and then Object_Access_Level (Expr)
 796                 > Subprogram_Access_Level (Scope_Id)
 797             then
 798                Rewrite (N,
 799                  Make_Raise_Program_Error (Loc,
 800                    Reason => PE_Accessibility_Check_Failed));
 801                Analyze (N);
 802
 803                Error_Msg_N
 804                  ("cannot return a local value by reference?", N);
 805                Error_Msg_NE
 806                  ("\& will be raised at run time?",
 807                   N, Standard_Program_Error);
 808             end if;
 809
 810          elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
 811             Error_Msg_N ("procedure cannot return value (use function)", N);
 812
 813          else
 814             Error_Msg_N ("accept statement cannot return value", N);
 815          end if;
 816
 817       --  No expression present
 818
 819       else
 820          if Kind = E_Function or Kind = E_Generic_Function then
 821             Error_Msg_N ("missing expression in return from function", N);
 822          end if;
 823
 824          if (Ekind (Scope_Id) = E_Procedure
 825               or else Ekind (Scope_Id) = E_Generic_Procedure)
 826            and then No_Return (Scope_Id)
 827          then
 828             Error_Msg_N
 829               ("RETURN statement not allowed (No_Return)", N);
 830          end if;
 831       end if;
 832
 833       Check_Unreachable_Code (N);
 834    end Analyze_Return_Statement;
 835
 836    -------------------------
 837    -- Analyze_Return_Type --
 838    -------------------------
 839
 840    procedure Analyze_Return_Type (N : Node_Id) is
 841       Designator : constant Entity_Id := Defining_Entity (N);
 842       Typ        : Entity_Id := Empty;
 843
 844    begin
 845       if Result_Definition (N) /= Error then
 846          if Nkind (Result_Definition (N)) = N_Access_Definition then
 847             Typ := Access_Definition (N, Result_Definition (N));
 848             Set_Parent (Typ, Result_Definition (N));
 849             Set_Is_Local_Anonymous_Access (Typ);
 850             Set_Etype (Designator, Typ);
 851
 852             --  Ada 2005 (AI-231): Static checks
 853
 854             --  Null_Exclusion_Static_Checks needs to be extended to handle
 855             --  null exclusion checks for function specifications. ???
 856
 857             --  if Null_Exclusion_Present (N) then
 858             --     Null_Exclusion_Static_Checks (Param_Spec);
 859             --  end if;
 860
 861          --  Subtype_Mark case
 862
 863          else
 864             Find_Type (Result_Definition (N));
 865             Typ := Entity (Result_Definition (N));
 866             Set_Etype (Designator, Typ);
 867
 868             if Ekind (Typ) = E_Incomplete_Type
 869               or else (Is_Class_Wide_Type (Typ)
 870                          and then
 871                            Ekind (Root_Type (Typ)) = E_Incomplete_Type)
 872             then
 873                Error_Msg_N
 874                  ("invalid use of incomplete type", Result_Definition (N));
 875             end if;
 876          end if;
 877
 878       else
 879          Set_Etype (Designator, Any_Type);
 880       end if;
 881    end Analyze_Return_Type;
 882
 883    -----------------------------
 884    -- Analyze_Subprogram_Body --
 885    -----------------------------
 886
 887    --  This procedure is called for regular subprogram bodies, generic bodies,
 888    --  and for subprogram stubs of both kinds. In the case of stubs, only the
 889    --  specification matters, and is used to create a proper declaration for
 890    --  the subprogram, or to perform conformance checks.
 891
 892    procedure Analyze_Subprogram_Body (N : Node_Id) is
 893       Loc          : constant Source_Ptr := Sloc (N);
 894       Body_Spec    : constant Node_Id    := Specification (N);
 895       Body_Id      : Entity_Id           := Defining_Entity (Body_Spec);
 896       Prev_Id      : constant Entity_Id  := Current_Entity_In_Scope (Body_Id);
 897       Body_Deleted : constant Boolean    := False;
 898
 899       HSS          : Node_Id;
 900       Spec_Id      : Entity_Id;
 901       Spec_Decl    : Node_Id   := Empty;
 902       Last_Formal  : Entity_Id := Empty;
 903       Conformant   : Boolean;
 904       Missing_Ret  : Boolean;
 905       P_Ent        : Entity_Id;
 906
 907       procedure Check_Inline_Pragma (Spec : in out Node_Id);
 908       --  Look ahead to recognize a pragma that may appear after the body.
 909       --  If there is a previous spec, check that it appears in the same
 910       --  declarative part. If the pragma is Inline_Always, perform inlining
 911       --  unconditionally, otherwise only if Front_End_Inlining is requested.
 912       --  If the body acts as a spec, and inlining is required, we create a
 913       --  subprogram declaration for it, in order to attach the body to inline.
 914
 915       procedure Copy_Parameter_List (Plist : List_Id);
 916       --  Comment required ???
 917
 918       procedure Verify_Overriding_Indicator;
 919       --  If there was a previous spec, the entity has been entered in the
 920       --  current scope previously. If the body itself carries an overriding
 921       --  indicator, check that it is consistent with the known status of the
 922       --  entity.
 923
 924       -------------------------
 925       -- Check_Inline_Pragma --
 926       -------------------------
 927
 928       procedure Check_Inline_Pragma (Spec : in out Node_Id) is
 929          Prag  : Node_Id;
 930          Plist : List_Id;
 931
 932       begin
 933          if not Expander_Active then
 934             return;
 935          end if;
 936
 937          if Is_List_Member (N)
 938            and then Present (Next (N))
 939            and then Nkind (Next (N)) = N_Pragma
 940          then
 941             Prag := Next (N);
 942
 943             if Nkind (Prag) = N_Pragma
 944               and then
 945                  (Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always
 946                   or else
 947                     (Front_End_Inlining
 948                      and then Get_Pragma_Id (Chars (Prag)) = Pragma_Inline))
 949               and then
 950                  Chars
 951                    (Expression (First (Pragma_Argument_Associations (Prag))))
 952                       = Chars (Body_Id)
 953             then
 954                Prag := Next (N);
 955             else
 956                Prag := Empty;
 957             end if;
 958          else
 959             Prag := Empty;
 960          end if;
 961
 962          if Present (Prag) then
 963             if Present (Spec_Id) then
 964                if List_Containing (N) =
 965                  List_Containing (Unit_Declaration_Node (Spec_Id))
 966                then
 967                   Analyze (Prag);
 968                end if;
 969
 970             else
 971                --  Create a subprogram declaration, to make treatment uniform
 972
 973                declare
 974                   Subp : constant Entity_Id :=
 975                     Make_Defining_Identifier (Loc, Chars (Body_Id));
 976                   Decl : constant Node_Id :=
 977                     Make_Subprogram_Declaration (Loc,
 978                       Specification =>  New_Copy_Tree (Specification (N)));
 979                begin
 980                   Set_Defining_Unit_Name (Specification (Decl), Subp);
 981
 982                   if Present (First_Formal (Body_Id)) then
 983                      Plist := New_List;
 984                      Copy_Parameter_List (Plist);
 985                      Set_Parameter_Specifications
 986                        (Specification (Decl), Plist);
 987                   end if;
 988
 989                   Insert_Before (N, Decl);
 990                   Analyze (Decl);
 991                   Analyze (Prag);
 992                   Set_Has_Pragma_Inline (Subp);
 993
 994                   if Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always then
 995                      Set_Is_Inlined (Subp);
 996                      Set_Next_Rep_Item (Prag, First_Rep_Item (Subp));
 997                      Set_First_Rep_Item (Subp, Prag);
 998                   end if;
 999
1000                   Spec := Subp;
1001                end;
1002             end if;
1003          end if;
1004       end Check_Inline_Pragma;
1005
1006       -------------------------
1007       -- Copy_Parameter_List --
1008       -------------------------
1009
1010       procedure Copy_Parameter_List (Plist : List_Id) is
1011          Formal : Entity_Id;
1012
1013       begin
1014          Formal := First_Formal (Body_Id);
1015
1016          while Present (Formal) loop
1017             Append
1018               (Make_Parameter_Specification (Loc,
1019                 Defining_Identifier =>
1020                   Make_Defining_Identifier (Sloc (Formal),
1021                     Chars => Chars (Formal)),
1022                 In_Present  => In_Present (Parent (Formal)),
1023                 Out_Present => Out_Present (Parent (Formal)),
1024              Parameter_Type =>
1025                   New_Reference_To (Etype (Formal), Loc),
1026                 Expression =>
1027                   New_Copy_Tree (Expression (Parent (Formal)))),
1028               Plist);
1029
1030             Next_Formal (Formal);
1031          end loop;
1032       end Copy_Parameter_List;
1033
1034       ---------------------------------
1035       -- Verify_Overriding_Indicator --
1036       ---------------------------------
1037
1038       procedure Verify_Overriding_Indicator is
1039       begin
1040          if Must_Override (Body_Spec)
1041            and then not Is_Overriding_Operation (Spec_Id)
1042          then
1043             Error_Msg_NE
1044               ("subprogram& is not overriding", Body_Spec, Spec_Id);
1045
1046          elsif Must_Not_Override (Body_Spec)
1047               and then Is_Overriding_Operation (Spec_Id)
1048          then
1049             Error_Msg_NE
1050               ("subprogram& overrides inherited operation",
1051                  Body_Spec, Spec_Id);
1052          end if;
1053       end Verify_Overriding_Indicator;
1054
1055    --  Start of processing for Analyze_Subprogram_Body
1056
1057    begin
1058       if Debug_Flag_C then
1059          Write_Str ("====  Compiling subprogram body ");
1060          Write_Name (Chars (Body_Id));
1061          Write_Str (" from ");
1062          Write_Location (Loc);
1063          Write_Eol;
1064       end if;
1065
1066       Trace_Scope (N, Body_Id, " Analyze subprogram");
1067
1068       --  Generic subprograms are handled separately. They always have a
1069       --  generic specification. Determine whether current scope has a
1070       --  previous declaration.
1071
1072       --  If the subprogram body is defined within an instance of the same
1073       --  name, the instance appears as a package renaming, and will be hidden
1074       --  within the subprogram.
1075
1076       if Present (Prev_Id)
1077         and then not Is_Overloadable (Prev_Id)
1078         and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
1079                    or else Comes_From_Source (Prev_Id))
1080       then
1081          if Is_Generic_Subprogram (Prev_Id) then
1082             Spec_Id := Prev_Id;
1083             Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1084             Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
1085
1086             Analyze_Generic_Subprogram_Body (N, Spec_Id);
1087             return;
1088
1089          else
1090             --  Previous entity conflicts with subprogram name. Attempting to
1091             --  enter name will post error.
1092
1093             Enter_Name (Body_Id);
1094             return;
1095          end if;
1096
1097       --  Non-generic case, find the subprogram declaration, if one was seen,
1098       --  or enter new overloaded entity in the current scope. If the
1099       --  Current_Entity is the Body_Id itself, the unit is being analyzed as
1100       --  part of the context of one of its subunits. No need to redo the
1101       --  analysis.
1102
1103       elsif Prev_Id = Body_Id
1104         and then Has_Completion (Body_Id)
1105       then
1106          return;
1107
1108       else
1109          Body_Id := Analyze_Subprogram_Specification (Body_Spec);
1110
1111          if Nkind (N) = N_Subprogram_Body_Stub
1112            or else No (Corresponding_Spec (N))
1113          then
1114             Spec_Id := Find_Corresponding_Spec (N);
1115
1116             --  If this is a duplicate body, no point in analyzing it
1117
1118             if Error_Posted (N) then
1119                return;
1120             end if;
1121
1122             --  A subprogram body should cause freezing of its own declaration,
1123             --  but if there was no previous explicit declaration, then the
1124             --  subprogram will get frozen too late (there may be code within
1125             --  the body that depends on the subprogram having been frozen,
1126             --  such as uses of extra formals), so we force it to be frozen
1127             --  here. Same holds if the body and the spec are compilation
1128             --  units.
1129
1130             if No (Spec_Id) then
1131                Freeze_Before (N, Body_Id);
1132
1133             elsif Nkind (Parent (N)) = N_Compilation_Unit then
1134                Freeze_Before (N, Spec_Id);
1135             end if;
1136          else
1137             Spec_Id := Corresponding_Spec (N);
1138          end if;
1139       end if;
1140
1141       --  Do not inline any subprogram that contains nested subprograms, since
1142       --  the backend inlining circuit seems to generate uninitialized
1143       --  references in this case. We know this happens in the case of front
1144       --  end ZCX support, but it also appears it can happen in other cases as
1145       --  well. The backend often rejects attempts to inline in the case of
1146       --  nested procedures anyway, so little if anything is lost by this.
1147       --  Note that this is test is for the benefit of the back-end. There is
1148       --  a separate test for front-end inlining that also rejects nested
1149       --  subprograms.
1150
1151       --  Do not do this test if errors have been detected, because in some
1152       --  error cases, this code blows up, and we don't need it anyway if
1153       --  there have been errors, since we won't get to the linker anyway.
1154
1155       if Comes_From_Source (Body_Id)
1156         and then Serious_Errors_Detected = 0
1157       then
1158          P_Ent := Body_Id;
1159          loop
1160             P_Ent := Scope (P_Ent);
1161             exit when No (P_Ent) or else P_Ent = Standard_Standard;
1162
1163             if Is_Subprogram (P_Ent) then
1164                Set_Is_Inlined (P_Ent, False);
1165
1166                if Comes_From_Source (P_Ent)
1167                  and then Has_Pragma_Inline (P_Ent)
1168                then
1169                   Cannot_Inline
1170                     ("cannot inline& (nested subprogram)?",
1171                      N, P_Ent);
1172                end if;
1173             end if;
1174          end loop;
1175       end if;
1176
1177       Check_Inline_Pragma (Spec_Id);
1178
1179       --  Case of fully private operation in the body of the protected type.
1180       --  We must create a declaration for the subprogram, in order to attach
1181       --  the protected subprogram that will be used in internal calls.
1182
1183       if No (Spec_Id)
1184         and then Comes_From_Source (N)
1185         and then Is_Protected_Type (Current_Scope)
1186       then
1187          declare
1188             Decl     : Node_Id;
1189             Plist    : List_Id;
1190             Formal   : Entity_Id;
1191             New_Spec : Node_Id;
1192
1193          begin
1194             Formal := First_Formal (Body_Id);
1195
1196             --  The protected operation always has at least one formal, namely
1197             --  the object itself, but it is only placed in the parameter list
1198             --  if expansion is enabled.
1199
1200             if Present (Formal)
1201               or else Expander_Active
1202             then
1203                Plist := New_List;
1204
1205             else
1206                Plist := No_List;
1207             end if;
1208
1209             Copy_Parameter_List (Plist);
1210
1211             if Nkind (Body_Spec) = N_Procedure_Specification then
1212                New_Spec :=
1213                  Make_Procedure_Specification (Loc,
1214                     Defining_Unit_Name =>
1215                       Make_Defining_Identifier (Sloc (Body_Id),
1216                         Chars => Chars (Body_Id)),
1217                     Parameter_Specifications => Plist);
1218             else
1219                New_Spec :=
1220                  Make_Function_Specification (Loc,
1221                     Defining_Unit_Name =>
1222                       Make_Defining_Identifier (Sloc (Body_Id),
1223                         Chars => Chars (Body_Id)),
1224                     Parameter_Specifications => Plist,
1225                     Result_Definition =>
1226                       New_Occurrence_Of (Etype (Body_Id), Loc));
1227             end if;
1228
1229             Decl :=
1230               Make_Subprogram_Declaration (Loc,
1231                 Specification => New_Spec);
1232             Insert_Before (N, Decl);
1233             Spec_Id := Defining_Unit_Name (New_Spec);
1234
1235             --  Indicate that the entity comes from source, to ensure that
1236             --  cross-reference information is properly generated. The body
1237             --  itself is rewritten during expansion, and the body entity will
1238             --  not appear in calls to the operation.
1239
1240             Set_Comes_From_Source (Spec_Id, True);
1241             Analyze (Decl);
1242             Set_Has_Completion (Spec_Id);
1243             Set_Convention (Spec_Id, Convention_Protected);
1244          end;
1245
1246       elsif Present (Spec_Id) then
1247          Spec_Decl := Unit_Declaration_Node (Spec_Id);
1248          Verify_Overriding_Indicator;
1249       end if;
1250
1251       --  Place subprogram on scope stack, and make formals visible. If there
1252       --  is a spec, the visible entity remains that of the spec.
1253
1254       if Present (Spec_Id) then
1255          Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
1256
1257          if Is_Child_Unit (Spec_Id) then
1258             Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False);
1259          end if;
1260
1261          if Style_Check then
1262             Style.Check_Identifier (Body_Id, Spec_Id);
1263          end if;
1264
1265          Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1266          Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
1267
1268          if Is_Abstract (Spec_Id) then
1269             Error_Msg_N ("an abstract subprogram cannot have a body", N);
1270             return;
1271          else
1272             Set_Convention (Body_Id, Convention (Spec_Id));
1273             Set_Has_Completion (Spec_Id);
1274
1275             if Is_Protected_Type (Scope (Spec_Id)) then
1276                Set_Privals_Chain (Spec_Id, New_Elmt_List);
1277             end if;
1278
1279             --  If this is a body generated for a renaming, do not check for
1280             --  full conformance. The check is redundant, because the spec of
1281             --  the body is a copy of the spec in the renaming declaration,
1282             --  and the test can lead to spurious errors on nested defaults.
1283
1284             if Present (Spec_Decl)
1285               and then not Comes_From_Source (N)
1286               and then
1287                 (Nkind (Original_Node (Spec_Decl)) =
1288                                         N_Subprogram_Renaming_Declaration
1289                    or else (Present (Corresponding_Body (Spec_Decl))
1290                               and then
1291                                 Nkind (Unit_Declaration_Node
1292                                         (Corresponding_Body (Spec_Decl))) =
1293                                            N_Subprogram_Renaming_Declaration))
1294             then
1295                Conformant := True;
1296             else
1297                Check_Conformance
1298                  (Body_Id, Spec_Id,
1299                    Fully_Conformant, True, Conformant, Body_Id);
1300             end if;
1301
1302             --  If the body is not fully conformant, we have to decide if we
1303             --  should analyze it or not. If it has a really messed up profile
1304             --  then we probably should not analyze it, since we will get too
1305             --  many bogus messages.
1306
1307             --  Our decision is to go ahead in the non-fully conformant case
1308             --  only if it is at least mode conformant with the spec. Note
1309             --  that the call to Check_Fully_Conformant has issued the proper
1310             --  error messages to complain about the lack of conformance.
1311
1312             if not Conformant
1313               and then not Mode_Conformant (Body_Id, Spec_Id)
1314             then
1315                return;
1316             end if;
1317          end if;
1318
1319          if Spec_Id /= Body_Id then
1320             Reference_Body_Formals (Spec_Id, Body_Id);
1321          end if;
1322
1323          if Nkind (N) /= N_Subprogram_Body_Stub then
1324             Set_Corresponding_Spec (N, Spec_Id);
1325
1326             --  Ada 2005 (AI-345): Restore the correct Etype: here we undo the
1327             --  work done by Analyze_Subprogram_Specification to allow the
1328             --  overriding of task, protected and interface primitives.
1329
1330             if Comes_From_Source (Spec_Id)
1331               and then Present (First_Entity (Spec_Id))
1332               and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
1333               and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
1334               and then Present (Abstract_Interfaces
1335                                 (Etype (First_Entity (Spec_Id))))
1336               and then Present (Corresponding_Concurrent_Type
1337                                 (Etype (First_Entity (Spec_Id))))
1338             then
1339                Set_Etype (First_Entity (Spec_Id),
1340                  Corresponding_Concurrent_Type
1341                    (Etype (First_Entity (Spec_Id))));
1342             end if;
1343
1344             --  Ada 2005: A formal that is an access parameter may have a
1345             --  designated type imported through a limited_with clause, while
1346             --  the body has a regular with clause. Update the types of the
1347             --  formals accordingly, so that the non-limited view of each type
1348             --  is available in the body. We have already verified that the
1349             --  declarations are type-conformant.
1350
1351             if Ada_Version >= Ada_05 then
1352                declare
1353                   F_Spec : Entity_Id;
1354                   F_Body : Entity_Id;
1355
1356                begin
1357                   F_Spec := First_Formal (Spec_Id);
1358                   F_Body := First_Formal (Body_Id);
1359
1360                   while Present (F_Spec) loop
1361                      if Ekind (Etype (F_Spec)) = E_Anonymous_Access_Type
1362                        and then
1363                          From_With_Type (Designated_Type (Etype (F_Spec)))
1364                      then
1365                         Set_Etype (F_Spec, Etype (F_Body));
1366                      end if;
1367
1368                      Next_Formal (F_Spec);
1369                      Next_Formal (F_Body);
1370                   end loop;
1371                end;
1372             end if;
1373
1374             --  Now make the formals visible, and place subprogram
1375             --  on scope stack.
1376
1377             Install_Formals (Spec_Id);
1378             Last_Formal := Last_Entity (Spec_Id);
1379             New_Scope (Spec_Id);
1380
1381             --  Make sure that the subprogram is immediately visible. For
1382             --  child units that have no separate spec this is indispensable.
1383             --  Otherwise it is safe albeit redundant.
1384
1385             Set_Is_Immediately_Visible (Spec_Id);
1386          end if;
1387
1388          Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
1389          Set_Ekind (Body_Id, E_Subprogram_Body);
1390          Set_Scope (Body_Id, Scope (Spec_Id));
1391
1392       --  Case of subprogram body with no previous spec
1393
1394       else
1395          if Style_Check
1396            and then Comes_From_Source (Body_Id)
1397            and then not Suppress_Style_Checks (Body_Id)
1398            and then not In_Instance
1399          then
1400             Style.Body_With_No_Spec (N);
1401          end if;
1402
1403          New_Overloaded_Entity (Body_Id);
1404
1405          if Nkind (N) /= N_Subprogram_Body_Stub then
1406             Set_Acts_As_Spec (N);
1407             Generate_Definition (Body_Id);
1408             Generate_Reference
1409               (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
1410             Generate_Reference_To_Formals (Body_Id);
1411             Install_Formals (Body_Id);
1412             New_Scope (Body_Id);
1413          end if;
1414       end if;
1415
1416       --  If this is the proper body of a stub, we must verify that the stub
1417       --  conforms to the body, and to the previous spec if one was present.
1418       --  we know already that the body conforms to that spec. This test is
1419       --  only required for subprograms that come from source.
1420
1421       if Nkind (Parent (N)) = N_Subunit
1422         and then Comes_From_Source (N)
1423         and then not Error_Posted (Body_Id)
1424         and then Nkind (Corresponding_Stub (Parent (N))) =
1425                                                 N_Subprogram_Body_Stub
1426       then
1427          declare
1428             Old_Id : constant Entity_Id :=
1429                        Defining_Entity
1430                          (Specification (Corresponding_Stub (Parent (N))));
1431
1432             Conformant : Boolean := False;
1433
1434          begin
1435             if No (Spec_Id) then
1436                Check_Fully_Conformant (Body_Id, Old_Id);
1437
1438             else
1439                Check_Conformance
1440                  (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
1441
1442                if not Conformant then
1443
1444                   --  The stub was taken to be a new declaration. Indicate
1445                   --  that it lacks a body.
1446
1447                   Set_Has_Completion (Old_Id, False);
1448                end if;
1449             end if;
1450          end;
1451       end if;
1452
1453       Set_Has_Completion (Body_Id);
1454       Check_Eliminated (Body_Id);
1455
1456       if Nkind (N) = N_Subprogram_Body_Stub then
1457          return;
1458
1459       elsif  Present (Spec_Id)
1460         and then Expander_Active
1461         and then
1462           (Is_Always_Inlined (Spec_Id)
1463              or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
1464       then
1465          Build_Body_To_Inline (N, Spec_Id);
1466       end if;
1467
1468       --  Ada 2005 (AI-262): In library subprogram bodies, after the analysis
1469       --  if its specification we have to install the private withed units.
1470
1471       if Is_Compilation_Unit (Body_Id)
1472         and then Scope (Body_Id) = Standard_Standard
1473       then
1474          Install_Private_With_Clauses (Body_Id);
1475       end if;
1476
1477       --  Now we can go on to analyze the body
1478
1479       HSS := Handled_Statement_Sequence (N);
1480       Set_Actual_Subtypes (N, Current_Scope);
1481       Analyze_Declarations (Declarations (N));
1482       Check_Completion;
1483       Analyze (HSS);
1484       Process_End_Label (HSS, 't', Current_Scope);
1485       End_Scope;
1486       Check_Subprogram_Order (N);
1487       Set_Analyzed (Body_Id);
1488
1489       --  If we have a separate spec, then the analysis of the declarations
1490       --  caused the entities in the body to be chained to the spec id, but
1491       --  we want them chained to the body id. Only the formal parameters
1492       --  end up chained to the spec id in this case.
1493
1494       if Present (Spec_Id) then
1495
1496          --  We must conform to the categorization of our spec
1497
1498          Validate_Categorization_Dependency (N, Spec_Id);
1499
1500          --  And if this is a child unit, the parent units must conform
1501
1502          if Is_Child_Unit (Spec_Id) then
1503             Validate_Categorization_Dependency
1504               (Unit_Declaration_Node (Spec_Id), Spec_Id);
1505          end if;
1506
1507          if Present (Last_Formal) then
1508             Set_Next_Entity
1509               (Last_Entity (Body_Id), Next_Entity (Last_Formal));
1510             Set_Next_Entity (Last_Formal, Empty);
1511             Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
1512             Set_Last_Entity (Spec_Id, Last_Formal);
1513
1514          else
1515             Set_First_Entity (Body_Id, First_Entity (Spec_Id));
1516             Set_Last_Entity  (Body_Id, Last_Entity (Spec_Id));
1517             Set_First_Entity (Spec_Id, Empty);
1518             Set_Last_Entity  (Spec_Id, Empty);
1519          end if;
1520       end if;
1521
1522       --  If function, check return statements
1523
1524       if Nkind (Body_Spec) = N_Function_Specification then
1525          declare
1526             Id : Entity_Id;
1527
1528          begin
1529             if Present (Spec_Id) then
1530                Id := Spec_Id;
1531             else
1532                Id := Body_Id;
1533             end if;
1534
1535             if Return_Present (Id) then
1536                Check_Returns (HSS, 'F', Missing_Ret);
1537
1538                if Missing_Ret then
1539                   Set_Has_Missing_Return (Id);
1540                end if;
1541
1542             elsif not Is_Machine_Code_Subprogram (Id)
1543               and then not Body_Deleted
1544             then
1545                Error_Msg_N ("missing RETURN statement in function body", N);
1546             end if;
1547          end;
1548
1549       --  If procedure with No_Return, check returns
1550
1551       elsif Nkind (Body_Spec) = N_Procedure_Specification
1552         and then Present (Spec_Id)
1553         and then No_Return (Spec_Id)
1554       then
1555          Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
1556       end if;
1557
1558       --  Now we are going to check for variables that are never modified in
1559       --  the body of the procedure. We omit these checks if the first
1560       --  statement of the procedure raises an exception. In particular this
1561       --  deals with the common idiom of a stubbed function, which might
1562       --  appear as something like
1563
1564       --     function F (A : Integer) return Some_Type;
1565       --        X : Some_Type;
1566       --     begin
1567       --        raise Program_Error;
1568       --        return X;
1569       --     end F;
1570
1571       --  Here the purpose of X is simply to satisfy the (annoying)
1572       --  requirement in Ada that there be at least one return, and we
1573       --  certainly do not want to go posting warnings on X that it is not
1574       --  initialized!
1575
1576       declare
1577          Stm : Node_Id := First (Statements (HSS));
1578
1579       begin
1580          --  Skip an initial label (for one thing this occurs when we are in
1581          --  front end ZCX mode, but in any case it is irrelevant).
1582
1583          if Nkind (Stm) = N_Label then
1584             Next (Stm);
1585          end if;
1586
1587          --  Do the test on the original statement before expansion
1588
1589          declare
1590             Ostm : constant Node_Id := Original_Node (Stm);
1591
1592          begin
1593             --  If explicit raise statement, return with no checks
1594
1595             if Nkind (Ostm) = N_Raise_Statement then
1596                return;
1597
1598             --  Check for explicit call cases which likely raise an exception
1599
1600             elsif Nkind (Ostm) = N_Procedure_Call_Statement then
1601                if Is_Entity_Name (Name (Ostm)) then
1602                   declare
1603                      Ent : constant Entity_Id := Entity (Name (Ostm));
1604
1605                   begin
1606                      --  If the procedure is marked No_Return, then likely it
1607                      --  raises an exception, but in any case it is not coming
1608                      --  back here, so no need to check beyond the call.
1609
1610                      if Ekind (Ent) = E_Procedure
1611                        and then No_Return (Ent)
1612                      then
1613                         return;
1614
1615                      --  If the procedure name is Raise_Exception, then also
1616                      --  assume that it raises an exception. The main target
1617                      --  here is Ada.Exceptions.Raise_Exception, but this name
1618                      --  is pretty evocative in any context! Note that the
1619                      --  procedure in Ada.Exceptions is not marked No_Return
1620                      --  because of the annoying case of the null exception Id.
1621
1622                      elsif Chars (Ent) = Name_Raise_Exception then
1623                         return;
1624                      end if;
1625                   end;
1626                end if;
1627             end if;
1628          end;
1629       end;
1630
1631       --  Check for variables that are never modified
1632
1633       declare
1634          E1, E2 : Entity_Id;
1635
1636       begin
1637          --  If there is a separate spec, then transfer Never_Set_In_Source
1638          --  flags from out parameters to the corresponding entities in the
1639          --  body. The reason we do that is we want to post error flags on
1640          --  the body entities, not the spec entities.
1641
1642          if Present (Spec_Id) then
1643             E1 := First_Entity (Spec_Id);
1644
1645             while Present (E1) loop
1646                if Ekind (E1) = E_Out_Parameter then
1647                   E2 := First_Entity (Body_Id);
1648                   while Present (E2) loop
1649                      exit when Chars (E1) = Chars (E2);
1650                      Next_Entity (E2);
1651                   end loop;
1652
1653                   if Present (E2) then
1654                      Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
1655                   end if;
1656                end if;
1657
1658                Next_Entity (E1);
1659             end loop;
1660          end if;
1661
1662          --  Check references in body unless it was deleted. Note that the
1663          --  check of Body_Deleted here is not just for efficiency, it is
1664          --  necessary to avoid junk warnings on formal parameters.
1665
1666          if not Body_Deleted then
1667             Check_References (Body_Id);
1668          end if;
1669       end;
1670    end Analyze_Subprogram_Body;
1671
1672    ------------------------------------
1673    -- Analyze_Subprogram_Declaration --
1674    ------------------------------------
1675
1676    procedure Analyze_Subprogram_Declaration (N : Node_Id) is
1677       Designator : constant Entity_Id :=
1678                      Analyze_Subprogram_Specification (Specification (N));
1679       Scop       : constant Entity_Id := Current_Scope;
1680
1681    --  Start of processing for Analyze_Subprogram_Declaration
1682
1683    begin
1684       Generate_Definition (Designator);
1685
1686       --  Check for RCI unit subprogram declarations against in-lined
1687       --  subprograms and subprograms having access parameter or limited
1688       --  parameter without Read and Write (RM E.2.3(12-13)).
1689
1690       Validate_RCI_Subprogram_Declaration (N);
1691
1692       Trace_Scope
1693         (N,
1694          Defining_Entity (N),
1695          " Analyze subprogram spec. ");
1696
1697       if Debug_Flag_C then
1698          Write_Str ("====  Compiling subprogram spec ");
1699          Write_Name (Chars (Designator));
1700          Write_Str (" from ");
1701          Write_Location (Sloc (N));
1702          Write_Eol;
1703       end if;
1704
1705       New_Overloaded_Entity (Designator);
1706       Check_Delayed_Subprogram (Designator);
1707
1708       --  What is the following code for, it used to be
1709
1710       --  ???   Set_Suppress_Elaboration_Checks
1711       --  ???     (Designator, Elaboration_Checks_Suppressed (Designator));
1712
1713       --  The following seems equivalent, but a bit dubious
1714
1715       if Elaboration_Checks_Suppressed (Designator) then
1716          Set_Kill_Elaboration_Checks (Designator);
1717       end if;
1718
1719       if Scop /= Standard_Standard
1720         and then not Is_Child_Unit (Designator)
1721       then
1722          Set_Categorization_From_Scope (Designator, Scop);
1723       else
1724          --  For a compilation unit, check for library-unit pragmas
1725
1726          New_Scope (Designator);
1727          Set_Categorization_From_Pragmas (N);
1728          Validate_Categorization_Dependency (N, Designator);
1729          Pop_Scope;
1730       end if;
1731
1732       --  For a compilation unit, set body required. This flag will only be
1733       --  reset if a valid Import or Interface pragma is processed later on.
1734
1735       if Nkind (Parent (N)) = N_Compilation_Unit then
1736          Set_Body_Required (Parent (N), True);
1737
1738          if Ada_Version >= Ada_05
1739            and then Nkind (Specification (N)) = N_Procedure_Specification
1740            and then Null_Present (Specification (N))
1741          then
1742             Error_Msg_N
1743               ("null procedure cannot be declared at library level", N);
1744          end if;
1745       end if;
1746
1747       Generate_Reference_To_Formals (Designator);
1748       Check_Eliminated (Designator);
1749
1750       --  Ada 2005: if procedure is declared with "is null" qualifier,
1751       --  it requires no body.
1752
1753       if Nkind (Specification (N)) = N_Procedure_Specification
1754         and then Null_Present (Specification (N))
1755       then
1756          Set_Has_Completion (Designator);
1757          Set_Is_Inlined (Designator);
1758       end if;
1759    end Analyze_Subprogram_Declaration;
1760
1761    --------------------------------------
1762    -- Analyze_Subprogram_Specification --
1763    --------------------------------------
1764
1765    --  Reminder: N here really is a subprogram specification (not a subprogram
1766    --  declaration). This procedure is called to analyze the specification in
1767    --  both subprogram bodies and subprogram declarations (specs).
1768
1769    function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
1770       Designator : constant Entity_Id := Defining_Entity (N);
1771       Formals    : constant List_Id   := Parameter_Specifications (N);
1772
1773       function Has_Interface_Formals (T : List_Id) return Boolean;
1774       --  Ada 2005 (AI-251): Returns true if some non class-wide interface
1775       --  formal is found.
1776
1777       ---------------------------
1778       -- Has_Interface_Formals --
1779       ---------------------------
1780
1781       function Has_Interface_Formals (T : List_Id) return Boolean is
1782          Param_Spec : Node_Id;
1783          Formal     : Entity_Id;
1784
1785       begin
1786          Param_Spec := First (T);
1787
1788          while Present (Param_Spec) loop
1789             Formal := Defining_Identifier (Param_Spec);
1790
1791             if Is_Class_Wide_Type (Etype (Formal)) then
1792                null;
1793
1794             elsif Is_Interface (Etype (Formal)) then
1795                return True;
1796             end if;
1797
1798             Next (Param_Spec);
1799          end loop;
1800
1801          return False;
1802       end Has_Interface_Formals;
1803
1804    --  Start of processing for Analyze_Subprogram_Specification
1805
1806    begin
1807       Generate_Definition (Designator);
1808
1809       if Nkind (N) = N_Function_Specification then
1810          Set_Ekind (Designator, E_Function);
1811          Set_Mechanism (Designator, Default_Mechanism);
1812
1813       else
1814          Set_Ekind (Designator, E_Procedure);
1815          Set_Etype (Designator, Standard_Void_Type);
1816       end if;
1817
1818       --  Introduce new scope for analysis of the formals and of the
1819       --  return type.
1820
1821       Set_Scope (Designator, Current_Scope);
1822
1823       if Present (Formals) then
1824          New_Scope (Designator);
1825          Process_Formals (Formals, N);
1826
1827          --  Ada 2005 (AI-345): Allow overriding primitives of protected
1828          --  interfaces by means of normal subprograms. For this purpose
1829          --  temporarily use the corresponding record type as the etype
1830          --  of the first formal.
1831
1832          if Ada_Version >= Ada_05
1833            and then Comes_From_Source (Designator)
1834            and then Present (First_Entity (Designator))
1835            and then (Ekind (Etype (First_Entity (Designator)))
1836                              = E_Protected_Type
1837                        or else
1838                      Ekind (Etype (First_Entity (Designator)))
1839                              = E_Task_Type)
1840            and then Present (Corresponding_Record_Type
1841                              (Etype (First_Entity (Designator))))
1842            and then Present (Abstract_Interfaces
1843                              (Corresponding_Record_Type
1844                              (Etype (First_Entity (Designator)))))
1845          then
1846             Set_Etype (First_Entity (Designator),
1847               Corresponding_Record_Type (Etype (First_Entity (Designator))));
1848          end if;
1849
1850          End_Scope;
1851
1852       elsif Nkind (N) = N_Function_Specification then
1853          Analyze_Return_Type (N);
1854       end if;
1855
1856       if Nkind (N) = N_Function_Specification then
1857          if Nkind (Designator) = N_Defining_Operator_Symbol then
1858             Valid_Operator_Definition (Designator);
1859          end if;
1860
1861          May_Need_Actuals (Designator);
1862
1863          if Is_Abstract (Etype (Designator))
1864            and then Nkind (Parent (N))
1865                       /= N_Abstract_Subprogram_Declaration
1866            and then (Nkind (Parent (N)))
1867                       /= N_Formal_Abstract_Subprogram_Declaration
1868            and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
1869                       or else not Is_Entity_Name (Name (Parent (N)))
1870                       or else not Is_Abstract (Entity (Name (Parent (N)))))
1871          then
1872             Error_Msg_N
1873               ("function that returns abstract type must be abstract", N);
1874          end if;
1875       end if;
1876
1877       if Ada_Version >= Ada_05
1878         and then Comes_From_Source (N)
1879         and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration
1880         and then (Nkind (N) /= N_Procedure_Specification
1881                     or else
1882                   not Null_Present (N))
1883         and then Has_Interface_Formals (Formals)
1884       then
1885          Error_Msg_Name_1 := Chars (Defining_Unit_Name
1886                                     (Specification (Parent (N))));
1887          Error_Msg_N
1888            ("(Ada 2005) interface subprogram % must be abstract or null", N);
1889       end if;
1890
1891       return Designator;
1892    end Analyze_Subprogram_Specification;
1893
1894    --------------------------
1895    -- Build_Body_To_Inline --
1896    --------------------------
1897
1898    procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
1899       Decl : constant Node_Id := Unit_Declaration_Node (Subp);
1900       Original_Body   : Node_Id;
1901       Body_To_Analyze : Node_Id;
1902       Max_Size        : constant := 10;
1903       Stat_Count      : Integer := 0;
1904
1905       function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
1906       --  Check for declarations that make inlining not worthwhile
1907
1908       function Has_Excluded_Statement   (Stats : List_Id) return Boolean;
1909       --  Check for statements that make inlining not worthwhile: any tasking
1910       --  statement, nested at any level. Keep track of total number of
1911       --  elementary statements, as a measure of acceptable size.
1912
1913       function Has_Pending_Instantiation return Boolean;
1914       --  If some enclosing body contains instantiations that appear before
1915       --  the corresponding generic body, the enclosing body has a freeze node
1916       --  so that it can be elaborated after the generic itself. This might
1917       --  conflict with subsequent inlinings, so that it is unsafe to try to
1918       --  inline in such a case.
1919
1920       function Has_Single_Return return Boolean;
1921       --  In general we cannot inline functions that return unconstrained
1922       --  type. However, we can handle such functions if all return statements
1923       --  return a local variable that is the only declaration in the body
1924       --  of the function. In that case the call can be replaced by that
1925       --  local variable as is done for other inlined calls.
1926
1927       procedure Remove_Pragmas;
1928       --  A pragma Unreferenced that mentions a formal parameter has no
1929       --  meaning when the body is inlined and the formals are rewritten.
1930       --  Remove it from body to inline. The analysis of the non-inlined body
1931       --  will handle the pragma properly.
1932
1933       function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
1934       --  If the body of the subprogram includes a call that returns an
1935       --  unconstrained type, the secondary stack is involved, and it
1936       --  is not worth inlining.
1937
1938       ------------------------------
1939       -- Has_Excluded_Declaration --
1940       ------------------------------
1941
1942       function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
1943          D : Node_Id;
1944
1945          function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
1946          --  Nested subprograms make a given body ineligible for inlining, but
1947          --  we make an exception for instantiations of unchecked conversion.
1948          --  The body has not been analyzed yet, so check the name, and verify
1949          --  that the visible entity with that name is the predefined unit.
1950
1951          -----------------------------
1952          -- Is_Unchecked_Conversion --
1953          -----------------------------
1954
1955          function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
1956             Id   : constant Node_Id := Name (D);
1957             Conv : Entity_Id;
1958
1959          begin
1960             if Nkind (Id) = N_Identifier
1961               and then Chars (Id) = Name_Unchecked_Conversion
1962             then
1963                Conv := Current_Entity (Id);
1964
1965             elsif (Nkind (Id) = N_Selected_Component
1966                     or else Nkind (Id) = N_Expanded_Name)
1967               and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
1968             then
1969                Conv := Current_Entity (Selector_Name (Id));
1970
1971             else
1972                return False;
1973             end if;
1974
1975             return Present (Conv)
1976               and then Is_Predefined_File_Name
1977                          (Unit_File_Name (Get_Source_Unit (Conv)))
1978               and then Is_Intrinsic_Subprogram (Conv);
1979          end Is_Unchecked_Conversion;
1980
1981       --  Start of processing for Has_Excluded_Declaration
1982
1983       begin
1984          D := First (Decls);
1985
1986          while Present (D) loop
1987             if       (Nkind (D) = N_Function_Instantiation
1988                         and then not Is_Unchecked_Conversion (D))
1989               or else Nkind (D) = N_Protected_Type_Declaration
1990               or else Nkind (D) = N_Package_Declaration
1991               or else Nkind (D) = N_Package_Instantiation
1992               or else Nkind (D) = N_Subprogram_Body
1993               or else Nkind (D) = N_Procedure_Instantiation
1994               or else Nkind (D) = N_Task_Type_Declaration
1995             then
1996                Cannot_Inline
1997                  ("cannot inline & (non-allowed declaration)?", D, Subp);
1998                return True;
1999             end if;
2000
2001             Next (D);
2002          end loop;
2003
2004          return False;
2005       end Has_Excluded_Declaration;
2006
2007       ----------------------------
2008       -- Has_Excluded_Statement --
2009       ----------------------------
2010
2011       function Has_Excluded_Statement (Stats : List_Id) return Boolean is
2012          S : Node_Id;
2013          E : Node_Id;
2014
2015       begin
2016          S := First (Stats);
2017
2018          while Present (S) loop
2019             Stat_Count := Stat_Count + 1;
2020
2021             if Nkind (S) = N_Abort_Statement
2022               or else Nkind (S) = N_Asynchronous_Select
2023               or else Nkind (S) = N_Conditional_Entry_Call
2024               or else Nkind (S) = N_Delay_Relative_Statement
2025               or else Nkind (S) = N_Delay_Until_Statement
2026               or else Nkind (S) = N_Selective_Accept
2027               or else Nkind (S) = N_Timed_Entry_Call
2028             then
2029                Cannot_Inline
2030                  ("cannot inline & (non-allowed statement)?", S, Subp);
2031                return True;
2032
2033             elsif Nkind (S) = N_Block_Statement then
2034                if Present (Declarations (S))
2035                  and then Has_Excluded_Declaration (Declarations (S))
2036                then
2037                   return True;
2038
2039                elsif Present (Handled_Statement_Sequence (S))
2040                   and then
2041                     (Present
2042                       (Exception_Handlers (Handled_Statement_Sequence (S)))
2043                      or else
2044                        Has_Excluded_Statement
2045                          (Statements (Handled_Statement_Sequence (S))))
2046                then
2047                   return True;
2048                end if;
2049
2050             elsif Nkind (S) = N_Case_Statement then
2051                E := First (Alternatives (S));
2052                while Present (E) loop
2053                   if Has_Excluded_Statement (Statements (E)) then
2054                      return True;
2055                   end if;
2056
2057                   Next (E);
2058                end loop;
2059
2060             elsif Nkind (S) = N_If_Statement then
2061                if Has_Excluded_Statement (Then_Statements (S)) then
2062                   return True;
2063                end if;
2064
2065                if Present (Elsif_Parts (S)) then
2066                   E := First (Elsif_Parts (S));
2067                   while Present (E) loop
2068                      if Has_Excluded_Statement (Then_Statements (E)) then
2069                         return True;
2070                      end if;
2071                      Next (E);
2072                   end loop;
2073                end if;
2074
2075                if Present (Else_Statements (S))
2076                  and then Has_Excluded_Statement (Else_Statements (S))
2077                then
2078                   return True;
2079                end if;
2080
2081             elsif Nkind (S) = N_Loop_Statement
2082               and then Has_Excluded_Statement (Statements (S))
2083             then
2084                return True;
2085             end if;
2086
2087             Next (S);
2088          end loop;
2089
2090          return False;
2091       end Has_Excluded_Statement;
2092
2093       -------------------------------
2094       -- Has_Pending_Instantiation --
2095       -------------------------------
2096
2097       function Has_Pending_Instantiation return Boolean is
2098          S : Entity_Id := Current_Scope;
2099
2100       begin
2101          while Present (S) loop
2102             if Is_Compilation_Unit (S)
2103               or else Is_Child_Unit (S)
2104             then
2105                return False;
2106             elsif Ekind (S) = E_Package
2107               and then Has_Forward_Instantiation (S)
2108             then
2109                return True;
2110             end if;
2111
2112             S := Scope (S);
2113          end loop;
2114
2115          return False;
2116       end Has_Pending_Instantiation;
2117
2118       ------------------------
2119       --  Has_Single_Return --
2120       ------------------------
2121
2122       function Has_Single_Return return Boolean is
2123          Return_Statement : Node_Id := Empty;
2124
2125          function Check_Return (N : Node_Id) return Traverse_Result;
2126
2127          ------------------
2128          -- Check_Return --
2129          ------------------
2130
2131          function Check_Return (N : Node_Id) return Traverse_Result is
2132          begin
2133             if Nkind (N) = N_Return_Statement then
2134                if Present (Expression (N))
2135                  and then Is_Entity_Name (Expression (N))
2136                then
2137                   if No (Return_Statement) then
2138                      Return_Statement := N;
2139                      return OK;
2140
2141                   elsif Chars (Expression (N)) =
2142                         Chars (Expression (Return_Statement))
2143                   then
2144                      return OK;
2145
2146                   else
2147                      return Abandon;
2148                   end if;
2149
2150                else
2151                   --  Expression has wrong form
2152
2153                   return Abandon;
2154                end if;
2155
2156             else
2157                return OK;
2158             end if;
2159          end Check_Return;
2160
2161          function Check_All_Returns is new Traverse_Func (Check_Return);
2162
2163       --  Start of processing for Has_Single_Return
2164
2165       begin
2166          return Check_All_Returns (N) = OK;
2167       end Has_Single_Return;
2168
2169       --------------------
2170       -- Remove_Pragmas --
2171       --------------------
2172
2173       procedure Remove_Pragmas is
2174          Decl : Node_Id;
2175          Nxt  : Node_Id;
2176
2177       begin
2178          Decl := First (Declarations (Body_To_Analyze));
2179          while Present (Decl) loop
2180             Nxt := Next (Decl);
2181
2182             if Nkind (Decl) = N_Pragma
2183               and then Chars (Decl) = Name_Unreferenced
2184             then
2185                Remove (Decl);
2186             end if;
2187
2188             Decl := Nxt;
2189          end loop;
2190       end Remove_Pragmas;
2191
2192       --------------------------
2193       -- Uses_Secondary_Stack --
2194       --------------------------
2195
2196       function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
2197          function Check_Call (N : Node_Id) return Traverse_Result;
2198          --  Look for function calls that return an unconstrained type
2199
2200          ----------------
2201          -- Check_Call --
2202          ----------------
2203
2204          function Check_Call (N : Node_Id) return Traverse_Result is
2205          begin
2206             if Nkind (N) = N_Function_Call
2207               and then Is_Entity_Name (Name (N))
2208               and then Is_Composite_Type (Etype (Entity (Name (N))))
2209               and then not Is_Constrained (Etype (Entity (Name (N))))
2210             then
2211                Cannot_Inline
2212                  ("cannot inline & (call returns unconstrained type)?",
2213                     N, Subp);
2214                return Abandon;
2215             else
2216                return OK;
2217             end if;
2218          end Check_Call;
2219
2220          function Check_Calls is new Traverse_Func (Check_Call);
2221
2222       begin
2223          return Check_Calls (Bod) = Abandon;
2224       end Uses_Secondary_Stack;
2225
2226    --  Start of processing for Build_Body_To_Inline
2227
2228    begin
2229       if Nkind (Decl) = N_Subprogram_Declaration
2230         and then Present (Body_To_Inline (Decl))
2231       then
2232          return;    --  Done already.
2233
2234       --  Functions that return unconstrained composite types will require
2235       --  secondary stack handling, and cannot currently be inlined.
2236       --  Ditto for functions that return controlled types, where controlled
2237       --  actions interfere in complex ways with inlining.
2238
2239       elsif Ekind (Subp) = E_Function
2240         and then not Is_Scalar_Type (Etype (Subp))
2241         and then not Is_Access_Type (Etype (Subp))
2242         and then not Is_Constrained (Etype (Subp))
2243         and then not Has_Single_Return
2244       then
2245          Cannot_Inline
2246            ("cannot inline & (unconstrained return type)?", N, Subp);
2247          return;
2248
2249       elsif Ekind (Subp) = E_Function
2250         and then Controlled_Type (Etype (Subp))
2251       then
2252          Cannot_Inline
2253            ("cannot inline & (controlled return type)?", N, Subp);
2254          return;
2255       end if;
2256
2257       if Present (Declarations (N))
2258         and then Has_Excluded_Declaration (Declarations (N))
2259       then
2260          return;
2261       end if;
2262
2263       if Present (Handled_Statement_Sequence (N)) then
2264          if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
2265             Cannot_Inline
2266               ("cannot inline& (exception handler)?",
2267                First (Exception_Handlers (Handled_Statement_Sequence (N))),
2268                Subp);
2269             return;
2270          elsif
2271            Has_Excluded_Statement
2272              (Statements (Handled_Statement_Sequence (N)))
2273          then
2274             return;
2275          end if;
2276       end if;
2277
2278       --  We do not inline a subprogram  that is too large, unless it is
2279       --  marked Inline_Always. This pragma does not suppress the other
2280       --  checks on inlining (forbidden declarations, handlers, etc).
2281
2282       if Stat_Count > Max_Size
2283         and then not Is_Always_Inlined (Subp)
2284       then
2285          Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
2286          return;
2287       end if;
2288
2289       if Has_Pending_Instantiation then
2290          Cannot_Inline
2291            ("cannot inline& (forward instance within enclosing body)?",
2292              N, Subp);
2293          return;
2294       end if;
2295
2296       --  Within an instance, the body to inline must be treated as a nested
2297       --  generic, so that the proper global references are preserved.
2298
2299       if In_Instance then
2300          Save_Env (Scope (Current_Scope), Scope (Current_Scope));
2301          Original_Body := Copy_Generic_Node (N, Empty, True);
2302       else
2303          Original_Body := Copy_Separate_Tree (N);
2304       end if;
2305
2306       --  We need to capture references to the formals in order to substitute
2307       --  the actuals at the point of inlining, i.e. instantiation. To treat
2308       --  the formals as globals to the body to inline, we nest it within
2309       --  a dummy parameterless subprogram, declared within the real one.
2310       --  To avoid generating an internal name (which is never public, and
2311       --  which affects serial numbers of other generated names), we use
2312       --  an internal symbol that cannot conflict with user declarations.
2313
2314       Set_Parameter_Specifications (Specification (Original_Body), No_List);
2315       Set_Defining_Unit_Name
2316         (Specification (Original_Body),
2317           Make_Defining_Identifier (Sloc (N), Name_uParent));
2318       Set_Corresponding_Spec (Original_Body, Empty);
2319
2320       Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
2321
2322       --  Set return type of function, which is also global and does not need
2323       --  to be resolved.
2324
2325       if Ekind (Subp) = E_Function then
2326          Set_Result_Definition (Specification (Body_To_Analyze),
2327            New_Occurrence_Of (Etype (Subp), Sloc (N)));
2328       end if;
2329
2330       if No (Declarations (N)) then
2331          Set_Declarations (N, New_List (Body_To_Analyze));
2332       else
2333          Append (Body_To_Analyze, Declarations (N));
2334       end if;
2335
2336       Expander_Mode_Save_And_Set (False);
2337       Remove_Pragmas;
2338
2339       Analyze (Body_To_Analyze);
2340       New_Scope (Defining_Entity (Body_To_Analyze));
2341       Save_Global_References (Original_Body);
2342       End_Scope;
2343       Remove (Body_To_Analyze);
2344
2345       Expander_Mode_Restore;
2346
2347       if In_Instance then
2348          Restore_Env;
2349       end if;
2350
2351       --  If secondary stk used there is no point in inlining. We have
2352       --  already issued the warning in this case, so nothing to do.
2353
2354       if Uses_Secondary_Stack (Body_To_Analyze) then
2355          return;
2356       end if;
2357
2358       Set_Body_To_Inline (Decl, Original_Body);
2359       Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
2360       Set_Is_Inlined (Subp);
2361    end Build_Body_To_Inline;
2362
2363    -------------------
2364    -- Cannot_Inline --
2365    -------------------
2366
2367    procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
2368    begin
2369       --  Do not emit warning if this is a predefined unit which is not
2370       --  the main unit. With validity checks enabled, some predefined
2371       --  subprograms may contain nested subprograms and become ineligible
2372       --  for inlining.
2373
2374       if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
2375         and then not In_Extended_Main_Source_Unit (Subp)
2376       then
2377          null;
2378
2379       elsif Is_Always_Inlined (Subp) then
2380
2381          --  Remove last character (question mark) to make this into an error,
2382          --  because the Inline_Always pragma cannot be obeyed.
2383
2384          Error_Msg_NE (Msg (1 .. Msg'Length - 1), N, Subp);
2385
2386       elsif Ineffective_Inline_Warnings then
2387          Error_Msg_NE (Msg, N, Subp);
2388       end if;
2389    end Cannot_Inline;
2390
2391    -----------------------
2392    -- Check_Conformance --
2393    -----------------------
2394
2395    procedure Check_Conformance
2396      (New_Id                   : Entity_Id;
2397       Old_Id                   : Entity_Id;
2398       Ctype                    : Conformance_Type;
2399       Errmsg                   : Boolean;
2400       Conforms                 : out Boolean;
2401       Err_Loc                  : Node_Id := Empty;
2402       Get_Inst                 : Boolean := False;
2403       Skip_Controlling_Formals : Boolean := False)
2404    is
2405       Old_Type   : constant Entity_Id := Etype (Old_Id);
2406       New_Type   : constant Entity_Id := Etype (New_Id);
2407       Old_Formal : Entity_Id;
2408       New_Formal : Entity_Id;
2409
2410       procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
2411       --  Post error message for conformance error on given node. Two messages
2412       --  are output. The first points to the previous declaration with a
2413       --  general "no conformance" message. The second is the detailed reason,
2414       --  supplied as Msg. The parameter N provide information for a possible
2415       --  & insertion in the message, and also provides the location for
2416       --  posting the message in the absence of a specified Err_Loc location.
2417
2418       -----------------------
2419       -- Conformance_Error --
2420       -----------------------
2421
2422       procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
2423          Enode : Node_Id;
2424
2425       begin
2426          Conforms := False;
2427
2428          if Errmsg then
2429             if No (Err_Loc) then
2430                Enode := N;
2431             else
2432                Enode := Err_Loc;
2433             end if;
2434
2435             Error_Msg_Sloc := Sloc (Old_Id);
2436
2437             case Ctype is
2438                when Type_Conformant =>
2439                   Error_Msg_N
2440                     ("not type conformant with declaration#!", Enode);
2441
2442                when Mode_Conformant =>
2443                   Error_Msg_N
2444                     ("not mode conformant with declaration#!", Enode);
2445
2446                when Subtype_Conformant =>
2447                   Error_Msg_N
2448                     ("not subtype conformant with declaration#!", Enode);
2449
2450                when Fully_Conformant =>
2451                   Error_Msg_N
2452                     ("not fully conformant with declaration#!", Enode);
2453             end case;
2454
2455             Error_Msg_NE (Msg, Enode, N);
2456          end if;
2457       end Conformance_Error;
2458
2459    --  Start of processing for Check_Conformance
2460
2461    begin
2462       Conforms := True;
2463
2464       --  We need a special case for operators, since they don't appear
2465       --  explicitly.
2466
2467       if Ctype = Type_Conformant then
2468          if Ekind (New_Id) = E_Operator
2469            and then Operator_Matches_Spec (New_Id, Old_Id)
2470          then
2471             return;
2472          end if;
2473       end if;
2474
2475       --  If both are functions/operators, check return types conform
2476
2477       if Old_Type /= Standard_Void_Type
2478         and then New_Type /= Standard_Void_Type
2479       then
2480          if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
2481             Conformance_Error ("return type does not match!", New_Id);
2482             return;
2483          end if;
2484
2485          --  Ada 2005 (AI-231): In case of anonymous access types check the
2486          --  null-exclusion and access-to-constant attributes must match.
2487
2488          if Ada_Version >= Ada_05
2489            and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
2490            and then
2491              (Can_Never_Be_Null (Old_Type)
2492                 /= Can_Never_Be_Null (New_Type)
2493               or else Is_Access_Constant (Etype (Old_Type))
2494                         /= Is_Access_Constant (Etype (New_Type)))
2495          then
2496             Conformance_Error ("return type does not match!", New_Id);
2497             return;
2498          end if;
2499
2500       --  If either is a function/operator and the other isn't, error
2501
2502       elsif Old_Type /= Standard_Void_Type
2503         or else New_Type /= Standard_Void_Type
2504       then
2505          Conformance_Error ("functions can only match functions!", New_Id);
2506          return;
2507       end if;
2508
2509       --  In subtype conformant case, conventions must match (RM 6.3.1(16))
2510       --  If this is a renaming as body, refine error message to indicate that
2511       --  the conflict is with the original declaration. If the entity is not
2512       --  frozen, the conventions don't have to match, the one of the renamed
2513       --  entity is inherited.
2514
2515       if Ctype >= Subtype_Conformant then
2516          if Convention (Old_Id) /= Convention (New_Id) then
2517
2518             if not Is_Frozen (New_Id) then
2519                null;
2520
2521             elsif Present (Err_Loc)
2522               and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
2523               and then Present (Corresponding_Spec (Err_Loc))
2524             then
2525                Error_Msg_Name_1 := Chars (New_Id);
2526                Error_Msg_Name_2 :=
2527                  Name_Ada + Convention_Id'Pos (Convention (New_Id));
2528
2529                Conformance_Error ("prior declaration for% has convention %!");
2530
2531             else
2532                Conformance_Error ("calling conventions do not match!");
2533             end if;
2534
2535             return;
2536
2537          elsif Is_Formal_Subprogram (Old_Id)
2538            or else Is_Formal_Subprogram (New_Id)
2539          then
2540             Conformance_Error ("formal subprograms not allowed!");
2541             return;
2542          end if;
2543       end if;
2544
2545       --  Deal with parameters
2546
2547       --  Note: we use the entity information, rather than going directly
2548       --  to the specification in the tree. This is not only simpler, but
2549       --  absolutely necessary for some cases of conformance tests between
2550       --  operators, where the declaration tree simply does not exist!
2551
2552       Old_Formal := First_Formal (Old_Id);
2553       New_Formal := First_Formal (New_Id);
2554
2555       while Present (Old_Formal) and then Present (New_Formal) loop
2556          if Is_Controlling_Formal (Old_Formal)
2557            and then Is_Controlling_Formal (New_Formal)
2558            and then Skip_Controlling_Formals
2559          then
2560             goto Skip_Controlling_Formal;
2561          end if;
2562
2563          if Ctype = Fully_Conformant then
2564
2565             --  Names must match. Error message is more accurate if we do
2566             --  this before checking that the types of the formals match.
2567
2568             if Chars (Old_Formal) /= Chars (New_Formal) then
2569                Conformance_Error ("name & does not match!", New_Formal);
2570
2571                --  Set error posted flag on new formal as well to stop
2572                --  junk cascaded messages in some cases.
2573
2574                Set_Error_Posted (New_Formal);
2575                return;
2576             end if;
2577          end if;
2578
2579          --  Types must always match. In the visible part of an instance,
2580          --  usual overloading rules for dispatching operations apply, and
2581          --  we check base types (not the actual subtypes).
2582
2583          if In_Instance_Visible_Part
2584            and then Is_Dispatching_Operation (New_Id)
2585          then
2586             if not Conforming_Types
2587               (Base_Type (Etype (Old_Formal)),
2588                  Base_Type (Etype (New_Formal)), Ctype, Get_Inst)
2589             then
2590                Conformance_Error ("type of & does not match!", New_Formal);
2591                return;
2592             end if;
2593
2594          elsif not Conforming_Types
2595            (Etype (Old_Formal), Etype (New_Formal), Ctype, Get_Inst)
2596          then
2597             Conformance_Error ("type of & does not match!", New_Formal);
2598             return;
2599          end if;
2600
2601          --  For mode conformance, mode must match
2602
2603          if Ctype >= Mode_Conformant
2604            and then Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal)
2605          then
2606             Conformance_Error ("mode of & does not match!", New_Formal);
2607             return;
2608          end if;
2609
2610          --  Full conformance checks
2611
2612          if Ctype = Fully_Conformant then
2613
2614             --  We have checked already that names match
2615
2616             if Parameter_Mode (Old_Formal) = E_In_Parameter then
2617
2618                --  Ada 2005 (AI-231): In case of anonymous access types check
2619                --  the null-exclusion and access-to-constant attributes must
2620                --  match.
2621
2622                if Ada_Version >= Ada_05
2623                  and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
2624                  and then
2625                    (Can_Never_Be_Null (Old_Formal)
2626                       /= Can_Never_Be_Null (New_Formal)
2627                     or else Is_Access_Constant (Etype (Old_Formal))
2628                               /= Is_Access_Constant (Etype (New_Formal)))
2629                then
2630                   --  It is allowed to omit the null-exclusion in case of
2631                   --  stream attribute subprograms
2632
2633                   declare
2634                      TSS_Name : TSS_Name_Type;
2635
2636                   begin
2637                      Get_Name_String (Chars (New_Id));
2638                      TSS_Name :=
2639                        TSS_Name_Type
2640                          (Name_Buffer
2641                             (Name_Len - TSS_Name'Length + 1 .. Name_Len));
2642
2643                      if TSS_Name /= TSS_Stream_Read
2644                        and then TSS_Name /= TSS_Stream_Write
2645                        and then TSS_Name /= TSS_Stream_Input
2646                        and then TSS_Name /= TSS_Stream_Output
2647                      then
2648                         Conformance_Error
2649                           ("type of & does not match!", New_Formal);
2650                         return;
2651                      end if;
2652                   end;
2653                end if;
2654
2655                --  Check default expressions for in parameters
2656
2657                declare
2658                   NewD : constant Boolean :=
2659                            Present (Default_Value (New_Formal));
2660                   OldD : constant Boolean :=
2661                            Present (Default_Value (Old_Formal));
2662                begin
2663                   if NewD or OldD then
2664
2665                      --  The old default value has been analyzed because the
2666                      --  current full declaration will have frozen everything
2667                      --  before. The new default values have not been
2668                      --  analyzed, so analyze them now before we check for
2669                      --  conformance.
2670
2671                      if NewD then
2672                         New_Scope (New_Id);
2673                         Analyze_Per_Use_Expression
2674                           (Default_Value (New_Formal), Etype (New_Formal));
2675                         End_Scope;
2676                      end if;
2677
2678                      if not (NewD and OldD)
2679                        or else not Fully_Conformant_Expressions
2680                                     (Default_Value (Old_Formal),
2681                                      Default_Value (New_Formal))
2682                      then
2683                         Conformance_Error
2684                           ("default expression for & does not match!",
2685                            New_Formal);
2686                         return;
2687                      end if;
2688                   end if;
2689                end;
2690             end if;
2691          end if;
2692
2693          --  A couple of special checks for Ada 83 mode. These checks are
2694          --  skipped if either entity is an operator in package Standard.
2695          --  or if either old or new instance is not from the source program.
2696
2697          if Ada_Version = Ada_83
2698            and then Sloc (Old_Id) > Standard_Location
2699            and then Sloc (New_Id) > Standard_Location
2700            and then Comes_From_Source (Old_Id)
2701            and then Comes_From_Source (New_Id)
2702          then
2703             declare
2704                Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
2705                New_Param : constant Node_Id := Declaration_Node (New_Formal);
2706
2707             begin
2708                --  Explicit IN must be present or absent in both cases. This
2709                --  test is required only in the full conformance case.
2710
2711                if In_Present (Old_Param) /= In_Present (New_Param)
2712                  and then Ctype = Fully_Conformant
2713                then
2714                   Conformance_Error
2715                     ("(Ada 83) IN must appear in both declarations",
2716                      New_Formal);
2717                   return;
2718                end if;
2719
2720                --  Grouping (use of comma in param lists) must be the same
2721                --  This is where we catch a misconformance like:
2722
2723                --    A,B : Integer
2724                --    A : Integer; B : Integer
2725
2726                --  which are represented identically in the tree except
2727                --  for the setting of the flags More_Ids and Prev_Ids.
2728
2729                if More_Ids (Old_Param) /= More_Ids (New_Param)
2730                  or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
2731                then
2732                   Conformance_Error
2733                     ("grouping of & does not match!", New_Formal);
2734                   return;
2735                end if;
2736             end;
2737          end if;
2738
2739          --  This label is required when skipping controlling formals
2740
2741          <<Skip_Controlling_Formal>>
2742
2743          Next_Formal (Old_Formal);
2744          Next_Formal (New_Formal);
2745       end loop;
2746
2747       if Present (Old_Formal) then
2748          Conformance_Error ("too few parameters!");
2749          return;
2750
2751       elsif Present (New_Formal) then
2752          Conformance_Error ("too many parameters!", New_Formal);
2753          return;
2754       end if;
2755    end Check_Conformance;
2756
2757    ------------------------------
2758    -- Check_Delayed_Subprogram --
2759    ------------------------------
2760
2761    procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
2762       F : Entity_Id;
2763
2764       procedure Possible_Freeze (T : Entity_Id);
2765       --  T is the type of either a formal parameter or of the return type.
2766       --  If T is not yet frozen and needs a delayed freeze, then the
2767       --  subprogram itself must be delayed.
2768
2769       ---------------------
2770       -- Possible_Freeze --
2771       ---------------------
2772
2773       procedure Possible_Freeze (T : Entity_Id) is
2774       begin
2775          if Has_Delayed_Freeze (T)
2776            and then not Is_Frozen (T)
2777          then
2778             Set_Has_Delayed_Freeze (Designator);
2779
2780          elsif Is_Access_Type (T)
2781            and then Has_Delayed_Freeze (Designated_Type (T))
2782            and then not Is_Frozen (Designated_Type (T))
2783          then
2784             Set_Has_Delayed_Freeze (Designator);
2785          end if;
2786       end Possible_Freeze;
2787
2788    --  Start of processing for Check_Delayed_Subprogram
2789
2790    begin
2791       --  Never need to freeze abstract subprogram
2792
2793       if Is_Abstract (Designator) then
2794          null;
2795       else
2796          --  Need delayed freeze if return type itself needs a delayed
2797          --  freeze and is not yet frozen.
2798
2799          Possible_Freeze (Etype (Designator));
2800          Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
2801
2802          --  Need delayed freeze if any of the formal types themselves need
2803          --  a delayed freeze and are not yet frozen.
2804
2805          F := First_Formal (Designator);
2806          while Present (F) loop
2807             Possible_Freeze (Etype (F));
2808             Possible_Freeze (Base_Type (Etype (F))); -- needed ???
2809             Next_Formal (F);
2810          end loop;
2811       end if;
2812
2813       --  Mark functions that return by reference. Note that it cannot be
2814       --  done for delayed_freeze subprograms because the underlying
2815       --  returned type may not be known yet (for private types)
2816
2817       if not Has_Delayed_Freeze (Designator)
2818         and then Expander_Active
2819       then
2820          declare
2821             Typ  : constant Entity_Id := Etype (Designator);
2822             Utyp : constant Entity_Id := Underlying_Type (Typ);
2823
2824          begin
2825             if Is_Return_By_Reference_Type (Typ) then
2826                Set_Returns_By_Ref (Designator);
2827
2828             elsif Present (Utyp) and then Controlled_Type (Utyp) then
2829                Set_Returns_By_Ref (Designator);
2830             end if;
2831          end;
2832       end if;
2833    end Check_Delayed_Subprogram;
2834
2835    ------------------------------------
2836    -- Check_Discriminant_Conformance --
2837    ------------------------------------
2838
2839    procedure Check_Discriminant_Conformance
2840      (N        : Node_Id;
2841       Prev     : Entity_Id;
2842       Prev_Loc : Node_Id)
2843    is
2844       Old_Discr      : Entity_Id := First_Discriminant (Prev);
2845       New_Discr      : Node_Id   := First (Discriminant_Specifications (N));
2846       New_Discr_Id   : Entity_Id;
2847       New_Discr_Type : Entity_Id;
2848
2849       procedure Conformance_Error (Msg : String; N : Node_Id);
2850       --  Post error message for conformance error on given node. Two messages
2851       --  are output. The first points to the previous declaration with a
2852       --  general "no conformance" message. The second is the detailed reason,
2853       --  supplied as Msg. The parameter N provide information for a possible
2854       --  & insertion in the message.
2855
2856       -----------------------
2857       -- Conformance_Error --
2858       -----------------------
2859
2860       procedure Conformance_Error (Msg : String; N : Node_Id) is
2861       begin
2862          Error_Msg_Sloc := Sloc (Prev_Loc);
2863          Error_Msg_N ("not fully conformant with declaration#!", N);
2864          Error_Msg_NE (Msg, N, N);
2865       end Conformance_Error;
2866
2867    --  Start of processing for Check_Discriminant_Conformance
2868
2869    begin
2870       while Present (Old_Discr) and then Present (New_Discr) loop
2871
2872          New_Discr_Id := Defining_Identifier (New_Discr);
2873
2874          --  The subtype mark of the discriminant on the full type has not
2875          --  been analyzed so we do it here. For an access discriminant a new
2876          --  type is created.
2877
2878          if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
2879             New_Discr_Type :=
2880               Access_Definition (N, Discriminant_Type (New_Discr));
2881
2882          else
2883             Analyze (Discriminant_Type (New_Discr));
2884             New_Discr_Type := Etype (Discriminant_Type (New_Discr));
2885          end if;
2886
2887          if not Conforming_Types
2888                   (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
2889          then
2890             Conformance_Error ("type of & does not match!", New_Discr_Id);
2891             return;
2892          else
2893             --  Treat the new discriminant as an occurrence of the old one,
2894             --  for navigation purposes, and fill in some semantic
2895             --  information, for completeness.
2896
2897             Generate_Reference (Old_Discr, New_Discr_Id, 'r');
2898             Set_Etype (New_Discr_Id, Etype (Old_Discr));
2899             Set_Scope (New_Discr_Id, Scope (Old_Discr));
2900          end if;
2901
2902          --  Names must match
2903
2904          if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
2905             Conformance_Error ("name & does not match!", New_Discr_Id);
2906             return;
2907          end if;
2908
2909          --  Default expressions must match
2910
2911          declare
2912             NewD : constant Boolean :=
2913                      Present (Expression (New_Discr));
2914             OldD : constant Boolean :=
2915                      Present (Expression (Parent (Old_Discr)));
2916
2917          begin
2918             if NewD or OldD then
2919
2920                --  The old default value has been analyzed and expanded,
2921                --  because the current full declaration will have frozen
2922                --  everything before. The new default values have not been
2923                --  expanded, so expand now to check conformance.
2924
2925                if NewD then
2926                   Analyze_Per_Use_Expression
2927                     (Expression (New_Discr), New_Discr_Type);
2928                end if;
2929
2930                if not (NewD and OldD)
2931                  or else not Fully_Conformant_Expressions
2932                               (Expression (Parent (Old_Discr)),
2933                                Expression (New_Discr))
2934
2935                then
2936                   Conformance_Error
2937                     ("default expression for & does not match!",
2938                      New_Discr_Id);
2939                   return;
2940                end if;
2941             end if;
2942          end;
2943
2944          --  In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
2945
2946          if Ada_Version = Ada_83 then
2947             declare
2948                Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
2949
2950             begin
2951                --  Grouping (use of comma in param lists) must be the same
2952                --  This is where we catch a misconformance like:
2953
2954                --    A,B : Integer
2955                --    A : Integer; B : Integer
2956
2957                --  which are represented identically in the tree except
2958                --  for the setting of the flags More_Ids and Prev_Ids.
2959
2960                if More_Ids (Old_Disc) /= More_Ids (New_Discr)
2961                  or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
2962                then
2963                   Conformance_Error
2964                     ("grouping of & does not match!", New_Discr_Id);
2965                   return;
2966                end if;
2967             end;
2968          end if;
2969
2970          Next_Discriminant (Old_Discr);
2971          Next (New_Discr);
2972       end loop;
2973
2974       if Present (Old_Discr) then
2975          Conformance_Error ("too few discriminants!", Defining_Identifier (N));
2976          return;
2977
2978       elsif Present (New_Discr) then
2979          Conformance_Error
2980            ("too many discriminants!", Defining_Identifier (New_Discr));
2981          return;
2982       end if;
2983    end Check_Discriminant_Conformance;
2984
2985    ----------------------------
2986    -- Check_Fully_Conformant --
2987    ----------------------------
2988
2989    procedure Check_Fully_Conformant
2990      (New_Id  : Entity_Id;
2991       Old_Id  : Entity_Id;
2992       Err_Loc : Node_Id := Empty)
2993    is
2994       Result : Boolean;
2995    begin
2996       Check_Conformance
2997         (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
2998    end Check_Fully_Conformant;
2999
3000    ---------------------------
3001    -- Check_Mode_Conformant --
3002    ---------------------------
3003
3004    procedure Check_Mode_Conformant
3005      (New_Id   : Entity_Id;
3006       Old_Id   : Entity_Id;
3007       Err_Loc  : Node_Id := Empty;
3008       Get_Inst : Boolean := False)
3009    is
3010       Result : Boolean;
3011
3012    begin
3013       Check_Conformance
3014         (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
3015    end Check_Mode_Conformant;
3016
3017    --------------------------------
3018    -- Check_Overriding_Indicator --
3019    --------------------------------
3020
3021    procedure Check_Overriding_Indicator
3022      (Subp          : Entity_Id;
3023       Does_Override : Boolean)
3024    is
3025       Decl : Node_Id;
3026       Spec : Node_Id;
3027
3028    begin
3029       if Ekind (Subp) = E_Enumeration_Literal then
3030
3031          --  No overriding indicator for literals
3032
3033          return;
3034
3035       else
3036          Decl := Unit_Declaration_Node (Subp);
3037       end if;
3038
3039       if Nkind (Decl) = N_Subprogram_Declaration
3040         or else Nkind (Decl) = N_Subprogram_Body
3041         or else Nkind (Decl) = N_Subprogram_Renaming_Declaration
3042         or else Nkind (Decl) = N_Subprogram_Body_Stub
3043       then
3044          Spec := Specification (Decl);
3045       else
3046          return;
3047       end if;
3048
3049       if not Does_Override then
3050          if Must_Override (Spec) then
3051             Error_Msg_NE ("subprogram& is not overriding", Spec, Subp);
3052          end if;
3053
3054       else
3055          if Must_Not_Override (Spec) then
3056             Error_Msg_NE
3057               ("subprogram& overrides inherited operation", Spec, Subp);
3058          end if;
3059       end if;
3060    end Check_Overriding_Indicator;
3061
3062    -------------------
3063    -- Check_Returns --
3064    -------------------
3065
3066    procedure Check_Returns
3067      (HSS  : Node_Id;
3068       Mode : Character;
3069       Err  : out Boolean;
3070       Proc : Entity_Id := Empty)
3071    is
3072       Handler : Node_Id;
3073
3074       procedure Check_Statement_Sequence (L : List_Id);
3075       --  Internal recursive procedure to check a list of statements for proper
3076       --  termination by a return statement (or a transfer of control or a
3077       --  compound statement that is itself internally properly terminated).
3078
3079       ------------------------------
3080       -- Check_Statement_Sequence --
3081       ------------------------------
3082
3083       procedure Check_Statement_Sequence (L : List_Id) is
3084          Last_Stm : Node_Id;
3085          Kind     : Node_Kind;
3086
3087          Raise_Exception_Call : Boolean;
3088          --  Set True if statement sequence terminated by Raise_Exception call
3089          --  or a Reraise_Occurrence call.
3090
3091       begin
3092          Raise_Exception_Call := False;
3093
3094          --  Get last real statement
3095
3096          Last_Stm := Last (L);
3097
3098          --  Don't count pragmas
3099
3100          while Nkind (Last_Stm) = N_Pragma
3101
3102          --  Don't count call to SS_Release (can happen after Raise_Exception)
3103
3104            or else
3105              (Nkind (Last_Stm) = N_Procedure_Call_Statement
3106                 and then
3107               Nkind (Name (Last_Stm)) = N_Identifier
3108                 and then
3109               Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
3110
3111          --  Don't count exception junk
3112
3113            or else
3114              ((Nkind (Last_Stm) = N_Goto_Statement
3115                  or else Nkind (Last_Stm) = N_Label
3116                  or else Nkind (Last_Stm) = N_Object_Declaration)
3117                and then Exception_Junk (Last_Stm))
3118          loop
3119             Prev (Last_Stm);
3120          end loop;
3121
3122          --  Here we have the "real" last statement
3123
3124          Kind := Nkind (Last_Stm);
3125
3126          --  Transfer of control, OK. Note that in the No_Return procedure
3127          --  case, we already diagnosed any explicit return statements, so
3128          --  we can treat them as OK in this context.
3129
3130          if Is_Transfer (Last_Stm) then
3131             return;
3132
3133          --  Check cases of explicit non-indirect procedure calls
3134
3135          elsif Kind = N_Procedure_Call_Statement
3136            and then Is_Entity_Name (Name (Last_Stm))
3137          then
3138             --  Check call to Raise_Exception procedure which is treated
3139             --  specially, as is a call to Reraise_Occurrence.
3140
3141             --  We suppress the warning in these cases since it is likely that
3142             --  the programmer really does not expect to deal with the case
3143             --  of Null_Occurrence, and thus would find a warning about a
3144             --  missing return curious, and raising Program_Error does not
3145             --  seem such a bad behavior if this does occur.
3146
3147             --  Note that in the Ada 2005 case for Raise_Exception, the actual
3148             --  behavior will be to raise Constraint_Error (see AI-329).
3149
3150             if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
3151                  or else
3152                Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
3153             then
3154                Raise_Exception_Call := True;
3155
3156                --  For Raise_Exception call, test first argument, if it is
3157                --  an attribute reference for a 'Identity call, then we know
3158                --  that the call cannot possibly return.
3159
3160                declare
3161                   Arg : constant Node_Id :=
3162                           Original_Node (First_Actual (Last_Stm));
3163
3164                begin
3165                   if Nkind (Arg) = N_Attribute_Reference
3166                     and then Attribute_Name (Arg) = Name_Identity
3167                   then
3168                      return;
3169                   end if;
3170                end;
3171             end if;
3172
3173          --  If statement, need to look inside if there is an else and check
3174          --  each constituent statement sequence for proper termination.
3175
3176          elsif Kind = N_If_Statement
3177            and then Present (Else_Statements (Last_Stm))
3178          then
3179             Check_Statement_Sequence (Then_Statements (Last_Stm));
3180             Check_Statement_Sequence (Else_Statements (Last_Stm));
3181
3182             if Present (Elsif_Parts (Last_Stm)) then
3183                declare
3184                   Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
3185
3186                begin
3187                   while Present (Elsif_Part) loop
3188                      Check_Statement_Sequence (Then_Statements (Elsif_Part));
3189                      Next (Elsif_Part);
3190                   end loop;
3191                end;
3192             end if;
3193
3194             return;
3195
3196          --  Case statement, check each case for proper termination
3197
3198          elsif Kind = N_Case_Statement then
3199             declare
3200                Case_Alt : Node_Id;
3201
3202             begin
3203                Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
3204                while Present (Case_Alt) loop
3205                   Check_Statement_Sequence (Statements (Case_Alt));
3206                   Next_Non_Pragma (Case_Alt);
3207                end loop;
3208             end;
3209
3210             return;
3211
3212          --  Block statement, check its handled sequence of statements
3213
3214          elsif Kind = N_Block_Statement then
3215             declare
3216                Err1 : Boolean;
3217
3218             begin
3219                Check_Returns
3220                  (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
3221
3222                if Err1 then
3223                   Err := True;
3224                end if;
3225
3226                return;
3227             end;
3228
3229          --  Loop statement. If there is an iteration scheme, we can definitely
3230          --  fall out of the loop. Similarly if there is an exit statement, we
3231          --  can fall out. In either case we need a following return.
3232
3233          elsif Kind = N_Loop_Statement then
3234             if Present (Iteration_Scheme (Last_Stm))
3235               or else Has_Exit (Entity (Identifier (Last_Stm)))
3236             then
3237                null;
3238
3239             --  A loop with no exit statement or iteration scheme if either
3240             --  an inifite loop, or it has some other exit (raise/return).
3241             --  In either case, no warning is required.
3242
3243             else
3244                return;
3245             end if;
3246
3247          --  Timed entry call, check entry call and delay alternatives
3248
3249          --  Note: in expanded code, the timed entry call has been converted
3250          --  to a set of expanded statements on which the check will work
3251          --  correctly in any case.
3252
3253          elsif Kind = N_Timed_Entry_Call then
3254             declare
3255                ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
3256                DCA : constant Node_Id := Delay_Alternative      (Last_Stm);
3257
3258             begin
3259                --  If statement sequence of entry call alternative is missing,
3260                --  then we can definitely fall through, and we post the error
3261                --  message on the entry call alternative itself.
3262
3263                if No (Statements (ECA)) then
3264                   Last_Stm := ECA;
3265
3266                --  If statement sequence of delay alternative is missing, then
3267                --  we can definitely fall through, and we post the error
3268                --  message on the delay alternative itself.
3269
3270                --  Note: if both ECA and DCA are missing the return, then we
3271                --  post only one message, should be enough to fix the bugs.
3272                --  If not we will get a message next time on the DCA when the
3273                --  ECA is fixed!
3274
3275                elsif No (Statements (DCA)) then
3276                   Last_Stm := DCA;
3277
3278                --  Else check both statement sequences
3279
3280                else
3281                   Check_Statement_Sequence (Statements (ECA));
3282                   Check_Statement_Sequence (Statements (DCA));
3283                   return;
3284                end if;
3285             end;
3286
3287          --  Conditional entry call, check entry call and else part
3288
3289          --  Note: in expanded code, the conditional entry call has been
3290          --  converted to a set of expanded statements on which the check
3291          --  will work correctly in any case.
3292
3293          elsif Kind = N_Conditional_Entry_Call then
3294             declare
3295                ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
3296
3297             begin
3298                --  If statement sequence of entry call alternative is missing,
3299                --  then we can definitely fall through, and we post the error
3300                --  message on the entry call alternative itself.
3301
3302                if No (Statements (ECA)) then
3303                   Last_Stm := ECA;
3304
3305                --  Else check statement sequence and else part
3306
3307                else
3308                   Check_Statement_Sequence (Statements (ECA));
3309                   Check_Statement_Sequence (Else_Statements (Last_Stm));
3310                   return;
3311                end if;
3312             end;
3313          end if;
3314
3315          --  If we fall through, issue appropriate message
3316
3317          if Mode = 'F' then
3318             if not Raise_Exception_Call then
3319                Error_Msg_N
3320                  ("?RETURN statement missing following this statement",
3321                   Last_Stm);
3322                Error_Msg_N
3323                  ("\?Program_Error may be raised at run time",
3324                   Last_Stm);
3325             end if;
3326
3327             --  Note: we set Err even though we have not issued a warning
3328             --  because we still have a case of a missing return. This is
3329             --  an extremely marginal case, probably will never be noticed
3330             --  but we might as well get it right.
3331
3332             Err := True;
3333
3334          --  Otherwise we have the case of a procedure marked No_Return
3335
3336          else
3337             Error_Msg_N
3338               ("?implied return after this statement will raise Program_Error",
3339                Last_Stm);
3340             Error_Msg_NE
3341               ("?procedure & is marked as No_Return",
3342                Last_Stm, Proc);
3343
3344             declare
3345                RE : constant Node_Id :=
3346                       Make_Raise_Program_Error (Sloc (Last_Stm),
3347                         Reason => PE_Implicit_Return);
3348             begin
3349                Insert_After (Last_Stm, RE);
3350                Analyze (RE);
3351             end;
3352          end if;
3353       end Check_Statement_Sequence;
3354
3355    --  Start of processing for Check_Returns
3356
3357    begin
3358       Err := False;
3359       Check_Statement_Sequence (Statements (HSS));
3360
3361       if Present (Exception_Handlers (HSS)) then
3362          Handler := First_Non_Pragma (Exception_Handlers (HSS));
3363          while Present (Handler) loop
3364             Check_Statement_Sequence (Statements (Handler));
3365             Next_Non_Pragma (Handler);
3366          end loop;
3367       end if;
3368    end Check_Returns;
3369
3370    ----------------------------
3371    -- Check_Subprogram_Order --
3372    ----------------------------
3373
3374    procedure Check_Subprogram_Order (N : Node_Id) is
3375
3376       function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
3377       --  This is used to check if S1 > S2 in the sense required by this
3378       --  test, for example nameab < namec, but name2 < name10.
3379
3380       -----------------------------
3381       -- Subprogram_Name_Greater --
3382       -----------------------------
3383
3384       function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
3385          L1, L2 : Positive;
3386          N1, N2 : Natural;
3387
3388       begin
3389          --  Remove trailing numeric parts
3390
3391          L1 := S1'Last;
3392          while S1 (L1) in '0' .. '9' loop
3393             L1 := L1 - 1;
3394          end loop;
3395
3396          L2 := S2'Last;
3397          while S2 (L2) in '0' .. '9' loop
3398             L2 := L2 - 1;
3399          end loop;
3400
3401          --  If non-numeric parts non-equal, that's decisive
3402
3403          if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
3404             return False;
3405
3406          elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
3407             return True;
3408
3409          --  If non-numeric parts equal, compare suffixed numeric parts. Note
3410          --  that a missing suffix is treated as numeric zero in this test.
3411
3412          else
3413             N1 := 0;
3414             while L1 < S1'Last loop
3415                L1 := L1 + 1;
3416                N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
3417             end loop;
3418
3419             N2 := 0;
3420             while L2 < S2'Last loop
3421                L2 := L2 + 1;
3422                N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
3423             end loop;
3424
3425             return N1 > N2;
3426          end if;
3427       end Subprogram_Name_Greater;
3428
3429    --  Start of processing for Check_Subprogram_Order
3430
3431    begin
3432       --  Check body in alpha order if this is option
3433
3434       if Style_Check
3435         and then Style_Check_Order_Subprograms
3436         and then Nkind (N) = N_Subprogram_Body
3437         and then Comes_From_Source (N)
3438         and then In_Extended_Main_Source_Unit (N)
3439       then
3440          declare
3441             LSN : String_Ptr
3442                     renames Scope_Stack.Table
3443                               (Scope_Stack.Last).Last_Subprogram_Name;
3444
3445             Body_Id : constant Entity_Id :=
3446                         Defining_Entity (Specification (N));
3447
3448          begin
3449             Get_Decoded_Name_String (Chars (Body_Id));
3450
3451             if LSN /= null then
3452                if Subprogram_Name_Greater
3453                     (LSN.all, Name_Buffer (1 .. Name_Len))
3454                then
3455                   Style.Subprogram_Not_In_Alpha_Order (Body_Id);
3456                end if;
3457
3458                Free (LSN);
3459             end if;
3460
3461             LSN := new String'(Name_Buffer (1 .. Name_Len));
3462          end;
3463       end if;
3464    end Check_Subprogram_Order;
3465
3466    ------------------------------
3467    -- Check_Subtype_Conformant --
3468    ------------------------------
3469
3470    procedure Check_Subtype_Conformant
3471      (New_Id  : Entity_Id;
3472       Old_Id  : Entity_Id;
3473       Err_Loc : Node_Id := Empty)
3474    is
3475       Result : Boolean;
3476    begin
3477       Check_Conformance
3478         (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
3479    end Check_Subtype_Conformant;
3480
3481    ---------------------------
3482    -- Check_Type_Conformant --
3483    ---------------------------
3484
3485    procedure Check_Type_Conformant
3486      (New_Id  : Entity_Id;
3487       Old_Id  : Entity_Id;
3488       Err_Loc : Node_Id := Empty)
3489    is
3490       Result : Boolean;
3491    begin
3492       Check_Conformance
3493         (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
3494    end Check_Type_Conformant;
3495
3496    ----------------------
3497    -- Conforming_Types --
3498    ----------------------
3499
3500    function Conforming_Types
3501      (T1       : Entity_Id;
3502       T2       : Entity_Id;
3503       Ctype    : Conformance_Type;
3504       Get_Inst : Boolean := False) return Boolean
3505    is
3506       Type_1 : Entity_Id := T1;
3507       Type_2 : Entity_Id := T2;
3508       Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
3509
3510       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
3511       --  If neither T1 nor T2 are generic actual types, or if they are
3512       --  in different scopes (e.g. parent and child instances), then verify
3513       --  that the base types are equal. Otherwise T1 and T2 must be
3514       --  on the same subtype chain. The whole purpose of this procedure
3515       --  is to prevent spurious ambiguities in an instantiation that may
3516       --  arise if two distinct generic types are instantiated with the
3517       --  same actual.
3518
3519       ----------------------
3520       -- Base_Types_Match --
3521       ----------------------
3522
3523       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
3524       begin
3525          if T1 = T2 then
3526             return True;
3527
3528          elsif Base_Type (T1) = Base_Type (T2) then
3529
3530             --  The following is too permissive. A more precise test must
3531             --  check that the generic actual is an ancestor subtype of the
3532             --  other ???.
3533
3534             return not Is_Generic_Actual_Type (T1)
3535               or else not Is_Generic_Actual_Type (T2)
3536               or else Scope (T1) /= Scope (T2);
3537
3538          --  In some cases a type imported through a limited_with clause,
3539          --  and its non-limited view are both visible, for example in an
3540          --  anonymous access_to_classwide type in a formal. Both entities
3541          --  designate the same type.
3542
3543          elsif From_With_Type (T1)
3544            and then Ekind (T1) = E_Incomplete_Type
3545            and then T2 = Non_Limited_View (T1)
3546          then
3547             return True;
3548
3549          elsif From_With_Type (T2)
3550            and then Ekind (T2) = E_Incomplete_Type
3551            and then T1 = Non_Limited_View (T2)
3552          then
3553             return True;
3554
3555          else
3556             return False;
3557          end if;
3558       end Base_Types_Match;
3559
3560       --  Start of processing for Conforming_Types
3561
3562    begin
3563       --  The context is an instance association for a formal
3564       --  access-to-subprogram type; the formal parameter types require
3565       --  mapping because they may denote other formal parameters of the
3566       --  generic unit.
3567
3568       if Get_Inst then
3569          Type_1 := Get_Instance_Of (T1);
3570          Type_2 := Get_Instance_Of (T2);
3571       end if;
3572
3573       --  First see if base types match
3574
3575       if Base_Types_Match (Type_1, Type_2) then
3576          return Ctype <= Mode_Conformant
3577            or else Subtypes_Statically_Match (Type_1, Type_2);
3578
3579       elsif Is_Incomplete_Or_Private_Type (Type_1)
3580         and then Present (Full_View (Type_1))
3581         and then Base_Types_Match (Full_View (Type_1), Type_2)
3582       then
3583          return Ctype <= Mode_Conformant
3584            or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
3585
3586       elsif Ekind (Type_2) = E_Incomplete_Type
3587         and then Present (Full_View (Type_2))
3588         and then Base_Types_Match (Type_1, Full_View (Type_2))
3589       then
3590          return Ctype <= Mode_Conformant
3591            or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
3592
3593       elsif Is_Private_Type (Type_2)
3594         and then In_Instance
3595         and then Present (Full_View (Type_2))
3596         and then Base_Types_Match (Type_1, Full_View (Type_2))
3597       then
3598          return Ctype <= Mode_Conformant
3599            or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
3600       end if;
3601
3602       --  Ada 2005 (AI-254): Anonymous access to subprogram types must be
3603       --  treated recursively because they carry a signature.
3604
3605       Are_Anonymous_Access_To_Subprogram_Types :=
3606
3607          --  Case 1: Anonymous access to subprogram types
3608
3609         (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
3610            and then Ekind (Type_2) = E_Anonymous_Access_Subprogram_Type)
3611
3612          --  Case 2: Anonymous access to PROTECTED subprogram types. In this
3613          --  case the anonymous type_declaration has been replaced by an
3614          --  occurrence of an internal access to subprogram type declaration
3615          --  available through the Original_Access_Type attribute
3616
3617         or else
3618           (Ekind (Type_1) = E_Access_Protected_Subprogram_Type
3619             and then Ekind (Type_2) = E_Access_Protected_Subprogram_Type
3620             and then not Comes_From_Source (Type_1)
3621             and then not Comes_From_Source (Type_2)
3622             and then Present (Original_Access_Type (Type_1))
3623             and then Present (Original_Access_Type (Type_2))
3624             and then Ekind (Original_Access_Type (Type_1)) =
3625                        E_Anonymous_Access_Protected_Subprogram_Type
3626             and then Ekind (Original_Access_Type (Type_2)) =
3627                        E_Anonymous_Access_Protected_Subprogram_Type);
3628
3629       --  Test anonymous access type case. For this case, static subtype
3630       --  matching is required for mode conformance (RM 6.3.1(15))
3631
3632       if (Ekind (Type_1) = E_Anonymous_Access_Type
3633             and then Ekind (Type_2) = E_Anonymous_Access_Type)
3634         or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
3635       then
3636          declare
3637             Desig_1 : Entity_Id;
3638             Desig_2 : Entity_Id;
3639
3640          begin
3641             Desig_1 := Directly_Designated_Type (Type_1);
3642
3643             --  An access parameter can designate an incomplete type
3644             --  If the incomplete type is the limited view of a type
3645             --  from a limited_with_clause, check whether the non-limited
3646             --  view is available.
3647
3648             if Ekind (Desig_1) = E_Incomplete_Type then
3649                if Present (Full_View (Desig_1)) then
3650                   Desig_1 := Full_View (Desig_1);
3651
3652                elsif Present (Non_Limited_View (Desig_1)) then
3653                   Desig_1 := Non_Limited_View (Desig_1);
3654                end if;
3655             end if;
3656
3657             Desig_2 := Directly_Designated_Type (Type_2);
3658
3659             if Ekind (Desig_2) = E_Incomplete_Type then
3660                if Present (Full_View (Desig_2)) then
3661                   Desig_2 := Full_View (Desig_2);
3662                elsif Present (Non_Limited_View (Desig_2)) then
3663                   Desig_2 := Non_Limited_View (Desig_2);
3664                end if;
3665             end if;
3666
3667             --  The context is an instance association for a formal
3668             --  access-to-subprogram type; formal access parameter designated
3669             --  types require mapping because they may denote other formal
3670             --  parameters of the generic unit.
3671
3672             if Get_Inst then
3673                Desig_1 := Get_Instance_Of (Desig_1);
3674                Desig_2 := Get_Instance_Of (Desig_2);
3675             end if;
3676
3677             --  It is possible for a Class_Wide_Type to be introduced for an
3678             --  incomplete type, in which case there is a separate class_ wide
3679             --  type for the full view. The types conform if their Etypes
3680             --  conform, i.e. one may be the full view of the other. This can
3681             --  only happen in the context of an access parameter, other uses
3682             --  of an incomplete Class_Wide_Type are illegal.
3683
3684             if Is_Class_Wide_Type (Desig_1)
3685               and then Is_Class_Wide_Type (Desig_2)
3686             then
3687                return
3688                  Conforming_Types
3689                    (Etype (Base_Type (Desig_1)),
3690                     Etype (Base_Type (Desig_2)), Ctype);
3691
3692             elsif Are_Anonymous_Access_To_Subprogram_Types then
3693                if Ada_Version < Ada_05 then
3694                   return Ctype = Type_Conformant
3695                     or else
3696                       Subtypes_Statically_Match (Desig_1, Desig_2);
3697
3698                --  We must check the conformance of the signatures themselves
3699
3700                else
3701                   declare
3702                      Conformant : Boolean;
3703                   begin
3704                      Check_Conformance
3705                        (Desig_1, Desig_2, Ctype, False, Conformant);
3706                      return Conformant;
3707                   end;
3708                end if;
3709
3710             else
3711                return Base_Type (Desig_1) = Base_Type (Desig_2)
3712                 and then (Ctype = Type_Conformant
3713                             or else
3714                           Subtypes_Statically_Match (Desig_1, Desig_2));
3715             end if;
3716          end;
3717
3718       --  Otherwise definitely no match
3719
3720       else
3721          if ((Ekind (Type_1) = E_Anonymous_Access_Type
3722                and then Is_Access_Type (Type_2))
3723             or else (Ekind (Type_2) = E_Anonymous_Access_Type
3724                        and then Is_Access_Type (Type_1)))
3725            and then
3726              Conforming_Types
3727                (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
3728          then
3729             May_Hide_Profile := True;
3730          end if;
3731
3732          return False;
3733       end if;
3734    end Conforming_Types;
3735
3736    --------------------------
3737    -- Create_Extra_Formals --
3738    --------------------------
3739
3740    procedure Create_Extra_Formals (E : Entity_Id) is
3741       Formal      : Entity_Id;
3742       Last_Extra  : Entity_Id;
3743       Formal_Type : Entity_Id;
3744       P_Formal    : Entity_Id := Empty;
3745
3746       function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id;
3747       --  Add an extra formal, associated with the current Formal. The extra
3748       --  formal is added to the list of extra formals, and also returned as
3749       --  the result. These formals are always of mode IN.
3750
3751       ----------------------
3752       -- Add_Extra_Formal --
3753       ----------------------
3754
3755       function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id is
3756          EF : constant Entity_Id :=
3757                 Make_Defining_Identifier (Sloc (Formal),
3758                   Chars => New_External_Name (Chars (Formal), 'F'));
3759
3760       begin
3761          --  We never generate extra formals if expansion is not active
3762          --  because we don't need them unless we are generating code.
3763
3764          if not Expander_Active then
3765             return Empty;
3766          end if;
3767
3768          --  A little optimization. Never generate an extra formal for the
3769          --  _init operand of an initialization procedure, since it could
3770          --  never be used.
3771
3772          if Chars (Formal) = Name_uInit then
3773             return Empty;
3774          end if;
3775
3776          Set_Ekind           (EF, E_In_Parameter);
3777          Set_Actual_Subtype  (EF, Typ);
3778          Set_Etype           (EF, Typ);
3779          Set_Scope           (EF, Scope (Formal));
3780          Set_Mechanism       (EF, Default_Mechanism);
3781          Set_Formal_Validity (EF);
3782
3783          Set_Extra_Formal (Last_Extra, EF);
3784          Last_Extra := EF;
3785          return EF;
3786       end Add_Extra_Formal;
3787
3788    --  Start of processing for Create_Extra_Formals
3789
3790    begin
3791       --  If this is a derived subprogram then the subtypes of the parent
3792       --  subprogram's formal parameters will be used to to determine the need
3793       --  for extra formals.
3794
3795       if Is_Overloadable (E) and then Present (Alias (E)) then
3796          P_Formal := First_Formal (Alias (E));
3797       end if;
3798
3799       Last_Extra := Empty;
3800       Formal := First_Formal (E);
3801       while Present (Formal) loop
3802          Last_Extra := Formal;
3803          Next_Formal (Formal);
3804       end loop;
3805
3806       --  If Extra_formals where already created, don't do it again. This
3807       --  situation may arise for subprogram types created as part of
3808       --  dispatching calls (see Expand_Dispatching_Call)
3809
3810       if Present (Last_Extra) and then
3811         Present (Extra_Formal (Last_Extra))
3812       then
3813          return;
3814       end if;
3815
3816       Formal := First_Formal (E);
3817
3818       while Present (Formal) loop
3819
3820          --  Create extra formal for supporting the attribute 'Constrained.
3821          --  The case of a private type view without discriminants also
3822          --  requires the extra formal if the underlying type has defaulted
3823          --  discriminants.
3824
3825          if Ekind (Formal) /= E_In_Parameter then
3826             if Present (P_Formal) then
3827                Formal_Type := Etype (P_Formal);
3828             else
3829                Formal_Type := Etype (Formal);
3830             end if;
3831
3832             --  Do not produce extra formals for Unchecked_Union parameters.
3833             --  Jump directly to the end of the loop.
3834
3835             if Is_Unchecked_Union (Base_Type (Formal_Type)) then
3836                goto Skip_Extra_Formal_Generation;
3837             end if;
3838
3839             if not Has_Discriminants (Formal_Type)
3840               and then Ekind (Formal_Type) in Private_Kind
3841               and then Present (Underlying_Type (Formal_Type))
3842             then
3843                Formal_Type := Underlying_Type (Formal_Type);
3844             end if;
3845
3846             if Has_Discriminants (Formal_Type)
3847               and then
3848                 ((not Is_Constrained (Formal_Type)
3849                     and then not Is_Indefinite_Subtype (Formal_Type))
3850                   or else Present (Extra_Formal (Formal)))
3851             then
3852                Set_Extra_Constrained
3853                  (Formal, Add_Extra_Formal (Standard_Boolean));
3854             end if;
3855          end if;
3856
3857          --  Create extra formal for supporting accessibility checking
3858
3859          --  This is suppressed if we specifically suppress accessibility
3860          --  checks at the pacage level for either the subprogram, or the
3861          --  package in which it resides. However, we do not suppress it
3862          --  simply if the scope has accessibility checks suppressed, since
3863          --  this could cause trouble when clients are compiled with a
3864          --  different suppression setting. The explicit checks at the
3865          --  package level are safe from this point of view.
3866
3867          if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
3868            and then not
3869              (Explicit_Suppress (E, Accessibility_Check)
3870                or else
3871               Explicit_Suppress (Scope (E), Accessibility_Check))
3872            and then
3873              (No (P_Formal)
3874                or else Present (Extra_Accessibility (P_Formal)))
3875          then
3876             --  Temporary kludge: for now we avoid creating the extra formal
3877             --  for access parameters of protected operations because of
3878             --  problem with the case of internal protected calls. ???
3879
3880             if Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Definition
3881               and then Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Body
3882             then
3883                Set_Extra_Accessibility
3884                  (Formal, Add_Extra_Formal (Standard_Natural));
3885             end if;
3886          end if;
3887
3888          if Present (P_Formal) then
3889             Next_Formal (P_Formal);
3890          end if;
3891
3892          --  This label is required when skipping extra formal generation for
3893          --  Unchecked_Union parameters.
3894
3895          <<Skip_Extra_Formal_Generation>>
3896
3897          Next_Formal (Formal);
3898       end loop;
3899    end Create_Extra_Formals;
3900
3901    -----------------------------
3902    -- Enter_Overloaded_Entity --
3903    -----------------------------
3904
3905    procedure Enter_Overloaded_Entity (S : Entity_Id) is
3906       E   : Entity_Id := Current_Entity_In_Scope (S);
3907       C_E : Entity_Id := Current_Entity (S);
3908
3909    begin
3910       if Present (E) then
3911          Set_Has_Homonym (E);
3912          Set_Has_Homonym (S);
3913       end if;
3914
3915       Set_Is_Immediately_Visible (S);
3916       Set_Scope (S, Current_Scope);
3917
3918       --  Chain new entity if front of homonym in current scope, so that
3919       --  homonyms are contiguous.
3920
3921       if Present (E)
3922         and then E /= C_E
3923       then
3924          while Homonym (C_E) /= E loop
3925             C_E := Homonym (C_E);
3926          end loop;
3927
3928          Set_Homonym (C_E, S);
3929
3930       else
3931          E := C_E;
3932          Set_Current_Entity (S);
3933       end if;
3934
3935       Set_Homonym (S, E);
3936
3937       Append_Entity (S, Current_Scope);
3938       Set_Public_Status (S);
3939
3940       if Debug_Flag_E then
3941          Write_Str ("New overloaded entity chain: ");
3942          Write_Name (Chars (S));
3943
3944          E := S;
3945          while Present (E) loop
3946             Write_Str (" "); Write_Int (Int (E));
3947             E := Homonym (E);
3948          end loop;
3949
3950          Write_Eol;
3951       end if;
3952
3953       --  Generate warning for hiding
3954
3955       if Warn_On_Hiding
3956         and then Comes_From_Source (S)
3957         and then In_Extended_Main_Source_Unit (S)
3958       then
3959          E := S;
3960          loop
3961             E := Homonym (E);
3962             exit when No (E);
3963
3964             --  Warn unless genuine overloading
3965
3966             if (not Is_Overloadable (E))
3967               or else Subtype_Conformant (E, S)
3968             then
3969                Error_Msg_Sloc := Sloc (E);
3970                Error_Msg_N ("declaration of & hides one#?", S);
3971             end if;
3972          end loop;
3973       end if;
3974    end Enter_Overloaded_Entity;
3975
3976    -----------------------------
3977    -- Find_Corresponding_Spec --
3978    -----------------------------
3979
3980    function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is
3981       Spec       : constant Node_Id   := Specification (N);
3982       Designator : constant Entity_Id := Defining_Entity (Spec);
3983
3984       E : Entity_Id;
3985
3986    begin
3987       E := Current_Entity (Designator);
3988
3989       while Present (E) loop
3990
3991          --  We are looking for a matching spec. It must have the same scope,
3992          --  and the same name, and either be type conformant, or be the case
3993          --  of a library procedure spec and its body (which belong to one
3994          --  another regardless of whether they are type conformant or not).
3995
3996          if Scope (E) = Current_Scope then
3997             if Current_Scope = Standard_Standard
3998               or else (Ekind (E) = Ekind (Designator)
3999                          and then Type_Conformant (E, Designator))
4000             then
4001                --  Within an instantiation, we know that spec and body are
4002                --  subtype conformant, because they were subtype conformant
4003                --  in the generic. We choose the subtype-conformant entity
4004                --  here as well, to resolve spurious ambiguities in the
4005                --  instance that were not present in the generic (i.e. when
4006                --  two different types are given the same actual). If we are
4007                --  looking for a spec to match a body, full conformance is
4008                --  expected.
4009
4010                if In_Instance then
4011                   Set_Convention (Designator, Convention (E));
4012
4013                   if Nkind (N) = N_Subprogram_Body
4014                     and then Present (Homonym (E))
4015                     and then not Fully_Conformant (E, Designator)
4016                   then
4017                      goto Next_Entity;
4018
4019                   elsif not Subtype_Conformant (E, Designator) then
4020                      goto Next_Entity;
4021                   end if;
4022                end if;
4023
4024                if not Has_Completion (E) then
4025
4026                   if Nkind (N) /= N_Subprogram_Body_Stub then
4027                      Set_Corresponding_Spec (N, E);
4028                   end if;
4029
4030                   Set_Has_Completion (E);
4031                   return E;
4032
4033                elsif Nkind (Parent (N)) = N_Subunit then
4034
4035                   --  If this is the proper body of a subunit, the completion
4036                   --  flag is set when analyzing the stub.
4037
4038                   return E;
4039
4040                --  If body already exists, this is an error unless the
4041                --  previous declaration is the implicit declaration of
4042                --  a derived subprogram, or this is a spurious overloading
4043                --  in an instance.
4044
4045                elsif No (Alias (E))
4046                  and then not Is_Intrinsic_Subprogram (E)
4047                  and then not In_Instance
4048                then
4049                   Error_Msg_Sloc := Sloc (E);
4050                   if Is_Imported (E) then
4051                      Error_Msg_NE
4052                       ("body not allowed for imported subprogram & declared#",
4053                         N, E);
4054                   else
4055                      Error_Msg_NE ("duplicate body for & declared#", N, E);
4056                   end if;
4057                end if;
4058
4059             elsif Is_Child_Unit (E)
4060               and then
4061                 Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
4062               and then
4063                 Nkind (Parent (Unit_Declaration_Node (Designator)))
4064                   = N_Compilation_Unit
4065             then
4066
4067                --  Child units cannot be overloaded, so a conformance mismatch
4068                --  between body and a previous spec is an error.
4069
4070                Error_Msg_N
4071                  ("body of child unit does not match previous declaration", N);
4072             end if;
4073          end if;
4074
4075          <<Next_Entity>>
4076             E := Homonym (E);
4077       end loop;
4078
4079       --  On exit, we know that no previous declaration of subprogram exists
4080
4081       return Empty;
4082    end Find_Corresponding_Spec;
4083
4084    ----------------------
4085    -- Fully_Conformant --
4086    ----------------------
4087
4088    function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
4089       Result : Boolean;
4090    begin
4091       Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
4092       return Result;
4093    end Fully_Conformant;
4094
4095    ----------------------------------
4096    -- Fully_Conformant_Expressions --
4097    ----------------------------------
4098
4099    function Fully_Conformant_Expressions
4100      (Given_E1 : Node_Id;
4101       Given_E2 : Node_Id) return Boolean
4102    is
4103       E1 : constant Node_Id := Original_Node (Given_E1);
4104       E2 : constant Node_Id := Original_Node (Given_E2);
4105       --  We always test conformance on original nodes, since it is possible
4106       --  for analysis and/or expansion to make things look as though they
4107       --  conform when they do not, e.g. by converting 1+2 into 3.
4108
4109       function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
4110         renames Fully_Conformant_Expressions;
4111
4112       function FCL (L1, L2 : List_Id) return Boolean;
4113       --  Compare elements of two lists for conformance. Elements have to
4114       --  be conformant, and actuals inserted as default parameters do not
4115       --  match explicit actuals with the same value.
4116
4117       function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
4118       --  Compare an operator node with a function call
4119
4120       ---------
4121       -- FCL --
4122       ---------
4123
4124       function FCL (L1, L2 : List_Id) return Boolean is
4125          N1, N2 : Node_Id;
4126
4127       begin
4128          if L1 = No_List then
4129             N1 := Empty;
4130          else
4131             N1 := First (L1);
4132          end if;
4133
4134          if L2 = No_List then
4135             N2 := Empty;
4136          else
4137             N2 := First (L2);
4138          end if;
4139
4140          --  Compare two lists, skipping rewrite insertions (we want to
4141          --  compare the original trees, not the expanded versions!)
4142
4143          loop
4144             if Is_Rewrite_Insertion (N1) then
4145                Next (N1);
4146             elsif Is_Rewrite_Insertion (N2) then
4147                Next (N2);
4148             elsif No (N1) then
4149                return No (N2);
4150             elsif No (N2) then
4151                return False;
4152             elsif not FCE (N1, N2) then
4153                return False;
4154             else
4155                Next (N1);
4156                Next (N2);
4157             end if;
4158          end loop;
4159       end FCL;
4160
4161       ---------
4162       -- FCO --
4163       ---------
4164
4165       function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
4166          Actuals : constant List_Id := Parameter_Associations (Call_Node);
4167          Act     : Node_Id;
4168
4169       begin
4170          if No (Actuals)
4171             or else Entity (Op_Node) /= Entity (Name (Call_Node))
4172          then
4173             return False;
4174
4175          else
4176             Act := First (Actuals);
4177
4178             if Nkind (Op_Node) in N_Binary_Op then
4179
4180                if not FCE (Left_Opnd (Op_Node), Act) then
4181                   return False;
4182                end if;
4183
4184                Next (Act);
4185             end if;
4186
4187             return Present (Act)
4188               and then FCE (Right_Opnd (Op_Node), Act)
4189               and then No (Next (Act));
4190          end if;
4191       end FCO;
4192
4193    --  Start of processing for Fully_Conformant_Expressions
4194
4195    begin
4196       --  Non-conformant if paren count does not match. Note: if some idiot
4197       --  complains that we don't do this right for more than 3 levels of
4198       --  parentheses, they will be treated with the respect they deserve :-)
4199
4200       if Paren_Count (E1) /= Paren_Count (E2) then
4201          return False;
4202
4203       --  If same entities are referenced, then they are conformant even if
4204       --  they have different forms (RM 8.3.1(19-20)).
4205
4206       elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
4207          if Present (Entity (E1)) then
4208             return Entity (E1) = Entity (E2)
4209               or else (Chars (Entity (E1)) = Chars (Entity (E2))
4210                         and then Ekind (Entity (E1)) = E_Discriminant
4211                         and then Ekind (Entity (E2)) = E_In_Parameter);
4212
4213          elsif Nkind (E1) = N_Expanded_Name
4214            and then Nkind (E2) = N_Expanded_Name
4215            and then Nkind (Selector_Name (E1)) = N_Character_Literal
4216            and then Nkind (Selector_Name (E2)) = N_Character_Literal
4217          then
4218             return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
4219
4220          else
4221             --  Identifiers in component associations don't always have
4222             --  entities, but their names must conform.
4223
4224             return Nkind  (E1) = N_Identifier
4225               and then Nkind (E2) = N_Identifier
4226               and then Chars (E1) = Chars (E2);
4227          end if;
4228
4229       elsif Nkind (E1) = N_Character_Literal
4230         and then Nkind (E2) = N_Expanded_Name
4231       then
4232          return Nkind (Selector_Name (E2)) = N_Character_Literal
4233            and then Chars (E1) = Chars (Selector_Name (E2));
4234
4235       elsif Nkind (E2) = N_Character_Literal
4236         and then Nkind (E1) = N_Expanded_Name
4237       then
4238          return Nkind (Selector_Name (E1)) = N_Character_Literal
4239            and then Chars (E2) = Chars (Selector_Name (E1));
4240
4241       elsif Nkind (E1) in N_Op
4242         and then Nkind (E2) = N_Function_Call
4243       then
4244          return FCO (E1, E2);
4245
4246       elsif Nkind (E2) in N_Op
4247         and then Nkind (E1) = N_Function_Call
4248       then
4249          return FCO (E2, E1);
4250
4251       --  Otherwise we must have the same syntactic entity
4252
4253       elsif Nkind (E1) /= Nkind (E2) then
4254          return False;
4255
4256       --  At this point, we specialize by node type
4257
4258       else
4259          case Nkind (E1) is
4260
4261             when N_Aggregate =>
4262                return
4263                  FCL (Expressions (E1), Expressions (E2))
4264                    and then FCL (Component_Associations (E1),
4265                                  Component_Associations (E2));
4266
4267             when N_Allocator =>
4268                if Nkind (Expression (E1)) = N_Qualified_Expression
4269                     or else
4270                   Nkind (Expression (E2)) = N_Qualified_Expression
4271                then
4272                   return FCE (Expression (E1), Expression (E2));
4273
4274                --  Check that the subtype marks and any constraints
4275                --  are conformant
4276
4277                else
4278                   declare
4279                      Indic1 : constant Node_Id := Expression (E1);
4280                      Indic2 : constant Node_Id := Expression (E2);
4281                      Elt1   : Node_Id;
4282                      Elt2   : Node_Id;
4283
4284                   begin
4285                      if Nkind (Indic1) /= N_Subtype_Indication then
4286                         return
4287                           Nkind (Indic2) /= N_Subtype_Indication
4288                             and then Entity (Indic1) = Entity (Indic2);
4289
4290                      elsif Nkind (Indic2) /= N_Subtype_Indication then
4291                         return
4292                           Nkind (Indic1) /= N_Subtype_Indication
4293                             and then Entity (Indic1) = Entity (Indic2);
4294
4295                      else
4296                         if Entity (Subtype_Mark (Indic1)) /=
4297                           Entity (Subtype_Mark (Indic2))
4298                         then
4299                            return False;
4300                         end if;
4301
4302                         Elt1 := First (Constraints (Constraint (Indic1)));
4303                         Elt2 := First (Constraints (Constraint (Indic2)));
4304
4305                         while Present (Elt1) and then Present (Elt2) loop
4306                            if not FCE (Elt1, Elt2) then
4307                               return False;
4308                            end if;
4309
4310                            Next (Elt1);
4311                            Next (Elt2);
4312                         end loop;
4313
4314                         return True;
4315                      end if;
4316                   end;
4317                end if;
4318
4319             when N_Attribute_Reference =>
4320                return
4321                  Attribute_Name (E1) = Attribute_Name (E2)
4322                    and then FCL (Expressions (E1), Expressions (E2));
4323
4324             when N_Binary_Op =>
4325                return
4326                  Entity (E1) = Entity (E2)
4327                    and then FCE (Left_Opnd  (E1), Left_Opnd  (E2))
4328                    and then FCE (Right_Opnd (E1), Right_Opnd (E2));
4329
4330             when N_And_Then | N_Or_Else | N_In | N_Not_In =>
4331                return
4332                  FCE (Left_Opnd  (E1), Left_Opnd  (E2))
4333                    and then
4334                  FCE (Right_Opnd (E1), Right_Opnd (E2));
4335
4336             when N_Character_Literal =>
4337                return
4338                  Char_Literal_Value (E1) = Char_Literal_Value (E2);
4339
4340             when N_Component_Association =>
4341                return
4342                  FCL (Choices (E1), Choices (E2))
4343                    and then FCE (Expression (E1), Expression (E2));
4344
4345             when N_Conditional_Expression =>
4346                return
4347                  FCL (Expressions (E1), Expressions (E2));
4348
4349             when N_Explicit_Dereference =>
4350                return
4351                  FCE (Prefix (E1), Prefix (E2));
4352
4353             when N_Extension_Aggregate =>
4354                return
4355                  FCL (Expressions (E1), Expressions (E2))
4356                    and then Null_Record_Present (E1) =
4357                             Null_Record_Present (E2)
4358                    and then FCL (Component_Associations (E1),
4359                                Component_Associations (E2));
4360
4361             when N_Function_Call =>
4362                return
4363                  FCE (Name (E1), Name (E2))
4364                    and then FCL (Parameter_Associations (E1),
4365                                  Parameter_Associations (E2));
4366
4367             when N_Indexed_Component =>
4368                return
4369                  FCE (Prefix (E1), Prefix (E2))
4370                    and then FCL (Expressions (E1), Expressions (E2));
4371
4372             when N_Integer_Literal =>
4373                return (Intval (E1) = Intval (E2));
4374
4375             when N_Null =>
4376                return True;
4377
4378             when N_Operator_Symbol =>
4379                return
4380                  Chars (E1) = Chars (E2);
4381
4382             when N_Others_Choice =>
4383                return True;
4384
4385             when N_Parameter_Association =>
4386                return
4387                  Chars (Selector_Name (E1))  = Chars (Selector_Name (E2))
4388                    and then FCE (Explicit_Actual_Parameter (E1),
4389                                  Explicit_Actual_Parameter (E2));
4390
4391             when N_Qualified_Expression =>
4392                return
4393                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
4394                    and then FCE (Expression (E1), Expression (E2));
4395
4396             when N_Range =>
4397                return
4398                  FCE (Low_Bound (E1), Low_Bound (E2))
4399                    and then FCE (High_Bound (E1), High_Bound (E2));
4400
4401             when N_Real_Literal =>
4402                return (Realval (E1) = Realval (E2));
4403
4404             when N_Selected_Component =>
4405                return
4406                  FCE (Prefix (E1), Prefix (E2))
4407                    and then FCE (Selector_Name (E1), Selector_Name (E2));
4408
4409             when N_Slice =>
4410                return
4411                  FCE (Prefix (E1), Prefix (E2))
4412                    and then FCE (Discrete_Range (E1), Discrete_Range (E2));
4413
4414             when N_String_Literal =>
4415                declare
4416                   S1 : constant String_Id := Strval (E1);
4417                   S2 : constant String_Id := Strval (E2);
4418                   L1 : constant Nat       := String_Length (S1);
4419                   L2 : constant Nat       := String_Length (S2);
4420
4421                begin
4422                   if L1 /= L2 then
4423                      return False;
4424
4425                   else
4426                      for J in 1 .. L1 loop
4427                         if Get_String_Char (S1, J) /=
4428                            Get_String_Char (S2, J)
4429                         then
4430                            return False;
4431                         end if;
4432                      end loop;
4433
4434                      return True;
4435                   end if;
4436                end;
4437
4438             when N_Type_Conversion =>
4439                return
4440                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
4441                    and then FCE (Expression (E1), Expression (E2));
4442
4443             when N_Unary_Op =>
4444                return
4445                  Entity (E1) = Entity (E2)
4446                    and then FCE (Right_Opnd (E1), Right_Opnd (E2));
4447
4448             when N_Unchecked_Type_Conversion =>
4449                return
4450                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
4451                    and then FCE (Expression (E1), Expression (E2));
4452
4453             --  All other node types cannot appear in this context. Strictly
4454             --  we should raise a fatal internal error. Instead we just ignore
4455             --  the nodes. This means that if anyone makes a mistake in the
4456             --  expander and mucks an expression tree irretrievably, the
4457             --  result will be a failure to detect a (probably very obscure)
4458             --  case of non-conformance, which is better than bombing on some
4459             --  case where two expressions do in fact conform.
4460
4461             when others =>
4462                return True;
4463
4464          end case;
4465       end if;
4466    end Fully_Conformant_Expressions;
4467
4468    ----------------------------------------
4469    -- Fully_Conformant_Discrete_Subtypes --
4470    ----------------------------------------
4471
4472    function Fully_Conformant_Discrete_Subtypes
4473      (Given_S1 : Node_Id;
4474       Given_S2 : Node_Id) return Boolean
4475    is
4476       S1 : constant Node_Id := Original_Node (Given_S1);
4477       S2 : constant Node_Id := Original_Node (Given_S2);
4478
4479       function Conforming_Bounds (B1, B2 : Node_Id) return Boolean;
4480       --  Special-case for a bound given by a discriminant, which in the body
4481       --  is replaced with the discriminal of the enclosing type.
4482
4483       function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
4484       --  Check both bounds
4485
4486       function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
4487       begin
4488          if Is_Entity_Name (B1)
4489            and then Is_Entity_Name (B2)
4490            and then Ekind (Entity (B1)) = E_Discriminant
4491          then
4492             return Chars (B1) = Chars (B2);
4493
4494          else
4495             return Fully_Conformant_Expressions (B1, B2);
4496          end if;
4497       end Conforming_Bounds;
4498
4499       function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
4500       begin
4501          return
4502            Conforming_Bounds (Low_Bound (R1), Low_Bound (R2))
4503              and then
4504            Conforming_Bounds (High_Bound (R1), High_Bound (R2));
4505       end Conforming_Ranges;
4506
4507    --  Start of processing for Fully_Conformant_Discrete_Subtypes
4508
4509    begin
4510       if Nkind (S1) /= Nkind (S2) then
4511          return False;
4512
4513       elsif Is_Entity_Name (S1) then
4514          return Entity (S1) = Entity (S2);
4515
4516       elsif Nkind (S1) = N_Range then
4517          return Conforming_Ranges (S1, S2);
4518
4519       elsif Nkind (S1) = N_Subtype_Indication then
4520          return
4521             Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2))
4522               and then
4523             Conforming_Ranges
4524               (Range_Expression (Constraint (S1)),
4525                Range_Expression (Constraint (S2)));
4526       else
4527          return True;
4528       end if;
4529    end Fully_Conformant_Discrete_Subtypes;
4530
4531    --------------------
4532    -- Install_Entity --
4533    --------------------
4534
4535    procedure Install_Entity (E : Entity_Id) is
4536       Prev : constant Entity_Id := Current_Entity (E);
4537    begin
4538       Set_Is_Immediately_Visible (E);
4539       Set_Current_Entity (E);
4540       Set_Homonym (E, Prev);
4541    end Install_Entity;
4542
4543    ---------------------
4544    -- Install_Formals --
4545    ---------------------
4546
4547    procedure Install_Formals (Id : Entity_Id) is
4548       F : Entity_Id;
4549    begin
4550       F := First_Formal (Id);
4551       while Present (F) loop
4552          Install_Entity (F);
4553          Next_Formal (F);
4554       end loop;
4555    end Install_Formals;
4556
4557    ---------------------------------
4558    -- Is_Non_Overriding_Operation --
4559    ---------------------------------
4560
4561    function Is_Non_Overriding_Operation
4562      (Prev_E : Entity_Id;
4563       New_E  : Entity_Id) return Boolean
4564    is
4565       Formal : Entity_Id;
4566       F_Typ  : Entity_Id;
4567       G_Typ  : Entity_Id := Empty;
4568
4569       function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
4570       --  If F_Type is a derived type associated with a generic actual
4571       --  subtype, then return its Generic_Parent_Type attribute, else return
4572       --  Empty.
4573
4574       function Types_Correspond
4575         (P_Type : Entity_Id;
4576          N_Type : Entity_Id) return Boolean;
4577       --  Returns true if and only if the types (or designated types in the
4578       --  case of anonymous access types) are the same or N_Type is derived
4579       --  directly or indirectly from P_Type.
4580
4581       -----------------------------
4582       -- Get_Generic_Parent_Type --
4583       -----------------------------
4584
4585       function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
4586          G_Typ : Entity_Id;
4587          Indic : Node_Id;
4588
4589       begin
4590          if Is_Derived_Type (F_Typ)
4591            and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
4592          then
4593             --  The tree must be traversed to determine the parent subtype in
4594             --  the generic unit, which unfortunately isn't always available
4595             --  via semantic attributes. ??? (Note: The use of Original_Node
4596             --  is needed for cases where a full derived type has been
4597             --  rewritten.)
4598
4599             Indic := Subtype_Indication
4600                        (Type_Definition (Original_Node (Parent (F_Typ))));
4601
4602             if Nkind (Indic) = N_Subtype_Indication then
4603                G_Typ := Entity (Subtype_Mark (Indic));
4604             else
4605                G_Typ := Entity (Indic);
4606             end if;
4607
4608             if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
4609               and then Present (Generic_Parent_Type (Parent (G_Typ)))
4610             then
4611                return Generic_Parent_Type (Parent (G_Typ));
4612             end if;
4613          end if;
4614
4615          return Empty;
4616       end Get_Generic_Parent_Type;
4617
4618       ----------------------
4619       -- Types_Correspond --
4620       ----------------------
4621
4622       function Types_Correspond
4623         (P_Type : Entity_Id;
4624          N_Type : Entity_Id) return Boolean
4625       is
4626          Prev_Type : Entity_Id := Base_Type (P_Type);
4627          New_Type  : Entity_Id := Base_Type (N_Type);
4628
4629       begin
4630          if Ekind (Prev_Type) = E_Anonymous_Access_Type then
4631             Prev_Type := Designated_Type (Prev_Type);
4632          end if;
4633
4634          if Ekind (New_Type) = E_Anonymous_Access_Type then
4635             New_Type := Designated_Type (New_Type);
4636          end if;
4637
4638          if Prev_Type = New_Type then
4639             return True;
4640
4641          elsif not Is_Class_Wide_Type (New_Type) then
4642             while Etype (New_Type) /= New_Type loop
4643                New_Type := Etype (New_Type);
4644                if New_Type = Prev_Type then
4645                   return True;
4646                end if;
4647             end loop;
4648          end if;
4649          return False;
4650       end Types_Correspond;
4651
4652    --  Start of processing for Is_Non_Overriding_Operation
4653
4654    begin
4655       --  In the case where both operations are implicit derived subprograms
4656       --  then neither overrides the other. This can only occur in certain
4657       --  obscure cases (e.g., derivation from homographs created in a generic
4658       --  instantiation).
4659
4660       if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
4661          return True;
4662
4663       elsif Ekind (Current_Scope) = E_Package
4664         and then Is_Generic_Instance (Current_Scope)
4665         and then In_Private_Part (Current_Scope)
4666         and then Comes_From_Source (New_E)
4667       then
4668          --  We examine the formals and result subtype of the inherited
4669          --  operation, to determine whether their type is derived from (the
4670          --  instance of) a generic type.
4671
4672          Formal := First_Formal (Prev_E);
4673
4674          while Present (Formal) loop
4675             F_Typ := Base_Type (Etype (Formal));
4676
4677             if Ekind (F_Typ) = E_Anonymous_Access_Type then
4678                F_Typ := Designated_Type (F_Typ);
4679             end if;
4680
4681             G_Typ := Get_Generic_Parent_Type (F_Typ);
4682
4683             Next_Formal (Formal);
4684          end loop;
4685
4686          if No (G_Typ) and then Ekind (Prev_E) = E_Function then
4687             G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
4688          end if;
4689
4690          if No (G_Typ) then
4691             return False;
4692          end if;
4693
4694          --  If the generic type is a private type, then the original
4695          --  operation was not overriding in the generic, because there was
4696          --  no primitive operation to override.
4697
4698          if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
4699            and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
4700              N_Formal_Private_Type_Definition
4701          then
4702             return True;
4703
4704          --  The generic parent type is the ancestor of a formal derived
4705          --  type declaration. We need to check whether it has a primitive
4706          --  operation that should be overridden by New_E in the generic.
4707
4708          else
4709             declare
4710                P_Formal : Entity_Id;
4711                N_Formal : Entity_Id;
4712                P_Typ    : Entity_Id;
4713                N_Typ    : Entity_Id;
4714                P_Prim   : Entity_Id;
4715                Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
4716
4717             begin
4718                while Present (Prim_Elt) loop
4719                   P_Prim := Node (Prim_Elt);
4720
4721                   if Chars (P_Prim) = Chars (New_E)
4722                     and then Ekind (P_Prim) = Ekind (New_E)
4723                   then
4724                      P_Formal := First_Formal (P_Prim);
4725                      N_Formal := First_Formal (New_E);
4726                      while Present (P_Formal) and then Present (N_Formal) loop
4727                         P_Typ := Etype (P_Formal);
4728                         N_Typ := Etype (N_Formal);
4729
4730                         if not Types_Correspond (P_Typ, N_Typ) then
4731                            exit;
4732                         end if;
4733
4734                         Next_Entity (P_Formal);
4735                         Next_Entity (N_Formal);
4736                      end loop;
4737
4738                      --  Found a matching primitive operation belonging to the
4739                      --  formal ancestor type, so the new subprogram is
4740                      --  overriding.
4741
4742                      if No (P_Formal)
4743                        and then No (N_Formal)
4744                        and then (Ekind (New_E) /= E_Function
4745                                   or else
4746                                  Types_Correspond
4747                                    (Etype (P_Prim), Etype (New_E)))
4748                      then
4749                         return False;
4750                      end if;
4751                   end if;
4752
4753                   Next_Elmt (Prim_Elt);
4754                end loop;
4755
4756                --  If no match found, then the new subprogram does not
4757                --  override in the generic (nor in the instance).
4758
4759                return True;
4760             end;
4761          end if;
4762       else
4763          return False;
4764       end if;
4765    end Is_Non_Overriding_Operation;
4766
4767    ------------------------------
4768    -- Make_Inequality_Operator --
4769    ------------------------------
4770
4771    --  S is the defining identifier of an equality operator. We build a
4772    --  subprogram declaration with the right signature. This operation is
4773    --  intrinsic, because it is always expanded as the negation of the
4774    --  call to the equality function.
4775
4776    procedure Make_Inequality_Operator (S : Entity_Id) is
4777       Loc     : constant Source_Ptr := Sloc (S);
4778       Decl    : Node_Id;
4779       Formals : List_Id;
4780       Op_Name : Entity_Id;
4781
4782       FF : constant Entity_Id := First_Formal (S);
4783       NF : constant Entity_Id := Next_Formal (FF);
4784
4785    begin
4786       --  Check that equality was properly defined, ignore call if not
4787
4788       if No (NF) then
4789          return;
4790       end if;
4791
4792       declare
4793          A : constant Entity_Id :=
4794                Make_Defining_Identifier (Sloc (FF),
4795                  Chars => Chars (FF));
4796
4797          B  : constant Entity_Id :=
4798                 Make_Defining_Identifier (Sloc (NF),
4799                   Chars => Chars (NF));
4800
4801       begin
4802          Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
4803
4804          Formals := New_List (
4805            Make_Parameter_Specification (Loc,
4806              Defining_Identifier => A,
4807              Parameter_Type      =>
4808                New_Reference_To (Etype (First_Formal (S)),
4809                  Sloc (Etype (First_Formal (S))))),
4810
4811            Make_Parameter_Specification (Loc,
4812              Defining_Identifier => B,
4813              Parameter_Type      =>
4814                New_Reference_To (Etype (Next_Formal (First_Formal (S))),
4815                  Sloc (Etype (Next_Formal (First_Formal (S)))))));
4816
4817          Decl :=
4818            Make_Subprogram_Declaration (Loc,
4819              Specification =>
4820                Make_Function_Specification (Loc,
4821                  Defining_Unit_Name       => Op_Name,
4822                  Parameter_Specifications => Formals,
4823                  Result_Definition        =>
4824                    New_Reference_To (Standard_Boolean, Loc)));
4825
4826          --  Insert inequality right after equality if it is explicit or after
4827          --  the derived type when implicit. These entities are created only
4828          --  for visibility purposes, and eventually replaced in the course of
4829          --  expansion, so they do not need to be attached to the tree and seen
4830          --  by the back-end. Keeping them internal also avoids spurious
4831          --  freezing problems. The declaration is inserted in the tree for
4832          --  analysis, and removed afterwards. If the equality operator comes
4833          --  from an explicit declaration, attach the inequality immediately
4834          --  after. Else the equality is inherited from a derived type
4835          --  declaration, so insert inequality after that declaration.
4836
4837          if No (Alias (S)) then
4838             Insert_After (Unit_Declaration_Node (S), Decl);
4839          elsif Is_List_Member (Parent (S)) then
4840             Insert_After (Parent (S), Decl);
4841          else
4842             Insert_After (Parent (Etype (First_Formal (S))), Decl);
4843          end if;
4844
4845          Mark_Rewrite_Insertion (Decl);
4846          Set_Is_Intrinsic_Subprogram (Op_Name);
4847          Analyze (Decl);
4848          Remove (Decl);
4849          Set_Has_Completion (Op_Name);
4850          Set_Corresponding_Equality (Op_Name, S);
4851          Set_Is_Abstract (Op_Name, Is_Abstract (S));
4852       end;
4853    end Make_Inequality_Operator;
4854
4855    ----------------------
4856    -- May_Need_Actuals --
4857    ----------------------
4858
4859    procedure May_Need_Actuals (Fun : Entity_Id) is
4860       F : Entity_Id;
4861       B : Boolean;
4862
4863    begin
4864       F := First_Formal (Fun);
4865       B := True;
4866
4867       while Present (F) loop
4868          if No (Default_Value (F)) then
4869             B := False;
4870             exit;
4871          end if;
4872
4873          Next_Formal (F);
4874       end loop;
4875
4876       Set_Needs_No_Actuals (Fun, B);
4877    end May_Need_Actuals;
4878
4879    ---------------------
4880    -- Mode_Conformant --
4881    ---------------------
4882
4883    function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
4884       Result : Boolean;
4885    begin
4886       Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
4887       return Result;
4888    end Mode_Conformant;
4889
4890    ---------------------------
4891    -- New_Overloaded_Entity --
4892    ---------------------------
4893
4894    procedure New_Overloaded_Entity
4895      (S            : Entity_Id;
4896       Derived_Type : Entity_Id := Empty)
4897    is
4898       Does_Override : Boolean := False;
4899       --  Set if the current scope has an operation that is type-conformant
4900       --  with S, and becomes hidden by S.
4901
4902       E : Entity_Id;
4903       --  Entity that S overrides
4904
4905       Prev_Vis : Entity_Id := Empty;
4906       --  Needs comment ???
4907
4908       Is_Alias_Interface : Boolean := False;
4909
4910       function Is_Private_Declaration (E : Entity_Id) return Boolean;
4911       --  Check that E is declared in the private part of the current package,
4912       --  or in the package body, where it may hide a previous declaration.
4913       --  We can't use In_Private_Part by itself because this flag is also
4914       --  set when freezing entities, so we must examine the place of the
4915       --  declaration in the tree, and recognize wrapper packages as well.
4916
4917       procedure Maybe_Primitive_Operation (Is_Overriding : Boolean := False);
4918       --  If the subprogram being analyzed is a primitive operation of
4919       --  the type of one of its formals, set the corresponding flag.
4920
4921       ----------------------------
4922       -- Is_Private_Declaration --
4923       ----------------------------
4924
4925       function Is_Private_Declaration (E : Entity_Id) return Boolean is
4926          Priv_Decls : List_Id;
4927          Decl       : constant Node_Id := Unit_Declaration_Node (E);
4928
4929       begin
4930          if Is_Package_Or_Generic_Package (Current_Scope)
4931            and then In_Private_Part (Current_Scope)
4932          then
4933             Priv_Decls :=
4934               Private_Declarations (
4935                 Specification (Unit_Declaration_Node (Current_Scope)));
4936
4937             return In_Package_Body (Current_Scope)
4938               or else
4939                 (Is_List_Member (Decl)
4940                    and then List_Containing (Decl) = Priv_Decls)
4941               or else (Nkind (Parent (Decl)) = N_Package_Specification
4942                          and then not Is_Compilation_Unit (
4943                            Defining_Entity (Parent (Decl)))
4944                          and then List_Containing (Parent (Parent (Decl)))
4945                            = Priv_Decls);
4946          else
4947             return False;
4948          end if;
4949       end Is_Private_Declaration;
4950
4951       -------------------------------
4952       -- Maybe_Primitive_Operation --
4953       -------------------------------
4954
4955       procedure Maybe_Primitive_Operation (Is_Overriding : Boolean := False) is
4956          Formal : Entity_Id;
4957          F_Typ  : Entity_Id;
4958          B_Typ  : Entity_Id;
4959
4960          function Visible_Part_Type (T : Entity_Id) return Boolean;
4961          --  Returns true if T is declared in the visible part of
4962          --  the current package scope; otherwise returns false.
4963          --  Assumes that T is declared in a package.
4964
4965          procedure Check_Private_Overriding (T : Entity_Id);
4966          --  Checks that if a primitive abstract subprogram of a visible
4967          --  abstract type is declared in a private part, then it must
4968          --  override an abstract subprogram declared in the visible part.
4969          --  Also checks that if a primitive function with a controlling
4970          --  result is declared in a private part, then it must override
4971          --  a function declared in the visible part.
4972
4973          ------------------------------
4974          -- Check_Private_Overriding --
4975          ------------------------------
4976
4977          procedure Check_Private_Overriding (T : Entity_Id) is
4978          begin
4979             if Ekind (Current_Scope) = E_Package
4980               and then In_Private_Part (Current_Scope)
4981               and then Visible_Part_Type (T)
4982               and then not In_Instance
4983             then
4984                if Is_Abstract (T)
4985                  and then Is_Abstract (S)
4986                  and then (not Is_Overriding or else not Is_Abstract (E))
4987                then
4988                   if not Is_Interface (T) then
4989                      Error_Msg_N ("abstract subprograms must be visible "
4990                                    & "('R'M 3.9.3(10))!", S);
4991
4992                   --  Ada 2005 (AI-251)
4993
4994                   else
4995                      Error_Msg_N ("primitive subprograms of interface types "
4996                        & "declared in a visible part, must be declared in "
4997                        & "the visible part ('R'M 3.9.4)!", S);
4998                   end if;
4999
5000                elsif Ekind (S) = E_Function
5001                  and then Is_Tagged_Type (T)
5002                  and then T = Base_Type (Etype (S))
5003                  and then not Is_Overriding
5004                then
5005                   Error_Msg_N
5006                     ("private function with tagged result must"
5007                      & " override visible-part function", S);
5008                   Error_Msg_N
5009                     ("\move subprogram to the visible part"
5010                      & " ('R'M 3.9.3(10))", S);
5011                end if;
5012             end if;
5013          end Check_Private_Overriding;
5014
5015          -----------------------
5016          -- Visible_Part_Type --
5017          -----------------------
5018
5019          function Visible_Part_Type (T : Entity_Id) return Boolean is
5020             P : constant Node_Id := Unit_Declaration_Node (Scope (T));
5021             N : Node_Id;
5022
5023          begin
5024             --  If the entity is a private type, then it must be
5025             --  declared in a visible part.
5026
5027             if Ekind (T) in Private_Kind then
5028                return True;
5029             end if;
5030
5031             --  Otherwise, we traverse the visible part looking for its
5032             --  corresponding declaration. We cannot use the declaration
5033             --  node directly because in the private part the entity of a
5034             --  private type is the one in the full view, which does not
5035             --  indicate that it is the completion of something visible.
5036
5037             N := First (Visible_Declarations (Specification (P)));
5038             while Present (N) loop
5039                if Nkind (N) = N_Full_Type_Declaration
5040                  and then Present (Defining_Identifier (N))
5041                  and then T = Defining_Identifier (N)
5042                then
5043                   return True;
5044
5045                elsif (Nkind (N) = N_Private_Type_Declaration
5046                        or else
5047                       Nkind (N) = N_Private_Extension_Declaration)
5048                  and then Present (Defining_Identifier (N))
5049                  and then T = Full_View (Defining_Identifier (N))
5050                then
5051                   return True;
5052                end if;
5053
5054                Next (N);
5055             end loop;
5056
5057             return False;
5058          end Visible_Part_Type;
5059
5060       --  Start of processing for Maybe_Primitive_Operation
5061
5062       begin
5063          if not Comes_From_Source (S) then
5064             null;
5065
5066          --  If the subprogram is at library level, it is not primitive
5067          --  operation.
5068
5069          elsif Current_Scope = Standard_Standard then
5070             null;
5071
5072          elsif (Ekind (Current_Scope) = E_Package
5073                  and then not In_Package_Body (Current_Scope))
5074            or else Is_Overriding
5075          then
5076             --  For function, check return type
5077
5078             if Ekind (S) = E_Function then
5079                B_Typ := Base_Type (Etype (S));
5080
5081                if Scope (B_Typ) = Current_Scope then
5082                   Set_Has_Primitive_Operations (B_Typ);
5083                   Check_Private_Overriding (B_Typ);
5084                end if;
5085             end if;
5086
5087             --  For all subprograms, check formals
5088
5089             Formal := First_Formal (S);
5090             while Present (Formal) loop
5091                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
5092                   F_Typ := Designated_Type (Etype (Formal));
5093                else
5094                   F_Typ := Etype (Formal);
5095                end if;
5096
5097                B_Typ := Base_Type (F_Typ);
5098
5099                if Scope (B_Typ) = Current_Scope then
5100                   Set_Has_Primitive_Operations (B_Typ);
5101                   Check_Private_Overriding (B_Typ);
5102                end if;
5103
5104                Next_Formal (Formal);
5105             end loop;
5106          end if;
5107       end Maybe_Primitive_Operation;
5108
5109    --  Start of processing for New_Overloaded_Entity
5110
5111    begin
5112       --  We need to look for an entity that S may override. This must be a
5113       --  homonym in the current scope, so we look for the first homonym of
5114       --  S in the current scope as the starting point for the search.
5115
5116       E := Current_Entity_In_Scope (S);
5117
5118       --  If there is no homonym then this is definitely not overriding
5119
5120       if No (E) then
5121          Enter_Overloaded_Entity (S);
5122          Check_Dispatching_Operation (S, Empty);
5123          Maybe_Primitive_Operation;
5124
5125          --  Ada 2005 (AI-397): Subprograms in the context of protected
5126          --  types have their overriding indicators checked in Sem_Ch9.
5127
5128          if Ekind (S) not in Subprogram_Kind
5129            or else Ekind (Scope (S)) /= E_Protected_Type
5130          then
5131             Check_Overriding_Indicator (S, False);
5132          end if;
5133
5134       --  If there is a homonym that is not overloadable, then we have an
5135       --  error, except for the special cases checked explicitly below.
5136
5137       elsif not Is_Overloadable (E) then
5138
5139          --  Check for spurious conflict produced by a subprogram that has the
5140          --  same name as that of the enclosing generic package. The conflict
5141          --  occurs within an instance, between the subprogram and the renaming
5142          --  declaration for the package. After the subprogram, the package
5143          --  renaming declaration becomes hidden.
5144
5145          if Ekind (E) = E_Package
5146            and then Present (Renamed_Object (E))
5147            and then Renamed_Object (E) = Current_Scope
5148            and then Nkind (Parent (Renamed_Object (E))) =
5149                                                      N_Package_Specification
5150            and then Present (Generic_Parent (Parent (Renamed_Object (E))))
5151          then
5152             Set_Is_Hidden (E);
5153             Set_Is_Immediately_Visible (E, False);
5154             Enter_Overloaded_Entity (S);
5155             Set_Homonym (S, Homonym (E));
5156             Check_Dispatching_Operation (S, Empty);
5157             Check_Overriding_Indicator (S, False);
5158
5159          --  If the subprogram is implicit it is hidden by the previous
5160          --  declaration. However if it is dispatching, it must appear in the
5161          --  dispatch table anyway, because it can be dispatched to even if it
5162          --  cannot be called directly.
5163
5164          elsif Present (Alias (S))
5165            and then not Comes_From_Source (S)
5166          then
5167             Set_Scope (S, Current_Scope);
5168
5169             if Is_Dispatching_Operation (Alias (S)) then
5170                Check_Dispatching_Operation (S, Empty);
5171             end if;
5172
5173             return;
5174
5175          else
5176             Error_Msg_Sloc := Sloc (E);
5177             Error_Msg_N ("& conflicts with declaration#", S);
5178
5179             --  Useful additional warning
5180
5181             if Is_Generic_Unit (E) then
5182                Error_Msg_N ("\previous generic unit cannot be overloaded", S);
5183             end if;
5184
5185             return;
5186          end if;
5187
5188       --  E exists and is overloadable
5189
5190       else
5191          Is_Alias_Interface :=
5192             Present (Alias (S))
5193             and then Is_Dispatching_Operation (Alias (S))
5194             and then Present (DTC_Entity (Alias (S)))
5195             and then Is_Interface (Scope (DTC_Entity (Alias (S))));
5196
5197          --  Loop through E and its homonyms to determine if any of them is
5198          --  the candidate for overriding by S.
5199
5200          while Present (E) loop
5201
5202             --  Definitely not interesting if not in the current scope
5203
5204             if Scope (E) /= Current_Scope then
5205                null;
5206
5207             --  Check if we have type conformance
5208
5209             --  Ada 2005 (AI-251): In case of overriding an interface
5210             --  subprogram it is not an error that the old and new entities
5211             --  have the same profile, and hence we skip this code.
5212
5213             elsif not Is_Alias_Interface
5214               and then Type_Conformant (E, S)
5215
5216                --  Ada 2005 (AI-251): Do not consider here entities that cover
5217                --  abstract interface primitives. They will be handled after
5218                --  the overriden entity is found (see comments bellow inside
5219                --  this subprogram).
5220
5221               and then not (Is_Subprogram (E)
5222                               and then Present (Abstract_Interface_Alias (E)))
5223             then
5224                --  If the old and new entities have the same profile and one
5225                --  is not the body of the other, then this is an error, unless
5226                --  one of them is implicitly declared.
5227
5228                --  There are some cases when both can be implicit, for example
5229                --  when both a literal and a function that overrides it are
5230                --  inherited in a derivation, or when an inhertited operation
5231                --  of a tagged full type overrides the ineherited operation of
5232                --  a private extension. Ada 83 had a special rule for the the
5233                --  literal case. In Ada95, the later implicit operation hides
5234                --  the former, and the literal is always the former. In the
5235                --  odd case where both are derived operations declared at the
5236                --  same point, both operations should be declared, and in that
5237                --  case we bypass the following test and proceed to the next
5238                --  part (this can only occur for certain obscure cases
5239                --  involving homographs in instances and can't occur for
5240                --  dispatching operations ???). Note that the following
5241                --  condition is less than clear. For example, it's not at all
5242                --  clear why there's a test for E_Entry here. ???
5243
5244                if Present (Alias (S))
5245                  and then (No (Alias (E))
5246                             or else Comes_From_Source (E)
5247                             or else Is_Dispatching_Operation (E))
5248                  and then
5249                    (Ekind (E) = E_Entry
5250                      or else Ekind (E) /= E_Enumeration_Literal)
5251                then
5252                   --  When an derived operation is overloaded it may be due to
5253                   --  the fact that the full view of a private extension
5254                   --  re-inherits. It has to be dealt with.
5255
5256                   if Is_Package_Or_Generic_Package (Current_Scope)
5257                     and then In_Private_Part (Current_Scope)
5258                   then
5259                      Check_Operation_From_Private_View (S, E);
5260                   end if;
5261
5262                   --  In any case the implicit operation remains hidden by
5263                   --  the existing declaration, which is overriding.
5264
5265                   Set_Is_Overriding_Operation (E);
5266
5267                   if Comes_From_Source (E) then
5268                      Check_Overriding_Indicator (E, True);
5269
5270                      --  Indicate that E overrides the operation from which
5271                      --  S is inherited.
5272
5273                      if  Present (Alias (S)) then
5274                         Set_Overridden_Operation (E, Alias (S));
5275                      else
5276                         Set_Overridden_Operation (E, S);
5277                      end if;
5278                   end if;
5279
5280                   return;
5281
5282                   --  Within an instance, the renaming declarations for
5283                   --  actual subprograms may become ambiguous, but they do
5284                   --  not hide each other.
5285
5286                elsif Ekind (E) /= E_Entry
5287                  and then not Comes_From_Source (E)
5288                  and then not Is_Generic_Instance (E)
5289                  and then (Present (Alias (E))
5290                             or else Is_Intrinsic_Subprogram (E))
5291                  and then (not In_Instance
5292                             or else No (Parent (E))
5293                             or else Nkind (Unit_Declaration_Node (E)) /=
5294                                N_Subprogram_Renaming_Declaration)
5295                then
5296                   --  A subprogram child unit is not allowed to override
5297                   --  an inherited subprogram (10.1.1(20)).
5298
5299                   if Is_Child_Unit (S) then
5300                      Error_Msg_N
5301                        ("child unit overrides inherited subprogram in parent",
5302                         S);
5303                      return;
5304                   end if;
5305
5306                   if Is_Non_Overriding_Operation (E, S) then
5307                      Enter_Overloaded_Entity (S);
5308                      if No (Derived_Type)
5309                        or else Is_Tagged_Type (Derived_Type)
5310                      then
5311                         Check_Dispatching_Operation (S, Empty);
5312                      end if;
5313
5314                      return;
5315                   end if;
5316
5317                   --  E is a derived operation or an internal operator which
5318                   --  is being overridden. Remove E from further visibility.
5319                   --  Furthermore, if E is a dispatching operation, it must be
5320                   --  replaced in the list of primitive operations of its type
5321                   --  (see Override_Dispatching_Operation).
5322
5323                   Does_Override := True;
5324
5325                   declare
5326                      Prev : Entity_Id;
5327
5328                   begin
5329                      Prev := First_Entity (Current_Scope);
5330
5331                      while Present (Prev)
5332                        and then Next_Entity (Prev) /= E
5333                      loop
5334                         Next_Entity (Prev);
5335                      end loop;
5336
5337                      --  It is possible for E to be in the current scope and
5338                      --  yet not in the entity chain. This can only occur in a
5339                      --  generic context where E is an implicit concatenation
5340                      --  in the formal part, because in a generic body the
5341                      --  entity chain starts with the formals.
5342
5343                      pragma Assert
5344                        (Present (Prev) or else Chars (E) = Name_Op_Concat);
5345
5346                      --  E must be removed both from the entity_list of the
5347                      --  current scope, and from the visibility chain
5348
5349                      if Debug_Flag_E then
5350                         Write_Str ("Override implicit operation ");
5351                         Write_Int (Int (E));
5352                         Write_Eol;
5353                      end if;
5354
5355                      --  If E is a predefined concatenation, it stands for four
5356                      --  different operations. As a result, a single explicit
5357                      --  declaration does not hide it. In a possible ambiguous
5358                      --  situation, Disambiguate chooses the user-defined op,
5359                      --  so it is correct to retain the previous internal one.
5360
5361                      if Chars (E) /= Name_Op_Concat
5362                        or else Ekind (E) /= E_Operator
5363                      then
5364                         --  For nondispatching derived operations that are
5365                         --  overridden by a subprogram declared in the private
5366                         --  part of a package, we retain the derived
5367                         --  subprogram but mark it as not immediately visible.
5368                         --  If the derived operation was declared in the
5369                         --  visible part then this ensures that it will still
5370                         --  be visible outside the package with the proper
5371                         --  signature (calls from outside must also be
5372                         --  directed to this version rather than the
5373                         --  overriding one, unlike the dispatching case).
5374                         --  Calls from inside the package will still resolve
5375                         --  to the overriding subprogram since the derived one
5376                         --  is marked as not visible within the package.
5377
5378                         --  If the private operation is dispatching, we achieve
5379                         --  the overriding by keeping the implicit operation
5380                         --  but setting its alias to be the overriding one. In
5381                         --  this fashion the proper body is executed in all
5382                         --  cases, but the original signature is used outside
5383                         --  of the package.
5384
5385                         --  If the overriding is not in the private part, we
5386                         --  remove the implicit operation altogether.
5387
5388                         if Is_Private_Declaration (S) then
5389
5390                            if not Is_Dispatching_Operation (E) then
5391                               Set_Is_Immediately_Visible (E, False);
5392                            else
5393                               --  Work done in Override_Dispatching_Operation,
5394                               --  so nothing else need to be done here.
5395
5396                               null;
5397                            end if;
5398
5399                         else
5400                            --  Find predecessor of E in Homonym chain
5401
5402                            if E = Current_Entity (E) then
5403                               Prev_Vis := Empty;
5404                            else
5405                               Prev_Vis := Current_Entity (E);
5406                               while Homonym (Prev_Vis) /= E loop
5407                                  Prev_Vis := Homonym (Prev_Vis);
5408                               end loop;
5409                            end if;
5410
5411                            if Prev_Vis /= Empty then
5412
5413                               --  Skip E in the visibility chain
5414
5415                               Set_Homonym (Prev_Vis, Homonym (E));
5416
5417                            else
5418                               Set_Name_Entity_Id (Chars (E), Homonym (E));
5419                            end if;
5420
5421                            Set_Next_Entity (Prev, Next_Entity (E));
5422
5423                            if No (Next_Entity (Prev)) then
5424                               Set_Last_Entity (Current_Scope, Prev);
5425                            end if;
5426
5427                         end if;
5428                      end if;
5429
5430                      Enter_Overloaded_Entity (S);
5431                      Set_Is_Overriding_Operation (S);
5432                      Check_Overriding_Indicator (S, True);
5433
5434                      --  Indicate that S overrides the operation from which
5435                      --  E is inherited.
5436
5437                      if Comes_From_Source (S) then
5438                         if Present (Alias (E)) then
5439                            Set_Overridden_Operation (S, Alias (E));
5440                         else
5441                            Set_Overridden_Operation (S, E);
5442                         end if;
5443                      end if;
5444
5445                      if Is_Dispatching_Operation (E) then
5446
5447                         --  An overriding dispatching subprogram inherits the
5448                         --  convention of the overridden subprogram (by
5449                         --  AI-117).
5450
5451                         Set_Convention (S, Convention (E));
5452
5453                         --  AI-251: For an entity overriding an interface
5454                         --  primitive check if the entity also covers other
5455                         --  abstract subprograms in the same scope. This is
5456                         --  required to handle the general case, that is,
5457                         --  1) overriding other interface primitives, and
5458                         --  2) overriding abstract subprograms inherited from
5459                         --  some abstract ancestor type.
5460
5461                         if Has_Homonym (E)
5462                           and then Present (Alias (E))
5463                           and then Ekind (Alias (E)) /= E_Operator
5464                           and then Present (DTC_Entity (Alias (E)))
5465                           and then Is_Interface (Scope (DTC_Entity
5466                                                         (Alias (E))))
5467                         then
5468                            declare
5469                               E1 : Entity_Id;
5470
5471                            begin
5472                               E1 := Homonym (E);
5473                               while Present (E1) loop
5474                                  if (Is_Overloadable (E1)
5475                                        or else Ekind (E1) = E_Subprogram_Type)
5476                                    and then Present (Alias (E1))
5477                                    and then Ekind (Alias (E1)) /= E_Operator
5478                                    and then Present (DTC_Entity (Alias (E1)))
5479                                    and then Is_Abstract
5480                                               (Scope (DTC_Entity (Alias (E1))))
5481                                    and then Type_Conformant (E1, S)
5482                                  then
5483                                     Check_Dispatching_Operation (S, E1);
5484                                  end if;
5485
5486                                  E1 := Homonym (E1);
5487                               end loop;
5488                            end;
5489                         end if;
5490
5491                         Check_Dispatching_Operation (S, E);
5492
5493                         --  AI-251: Handle the case in which the entity
5494                         --  overrides a primitive operation that covered
5495                         --  several abstract interface primitives.
5496
5497                         declare
5498                            E1 : Entity_Id;
5499                         begin
5500                            E1 := Current_Entity_In_Scope (S);
5501                            while Present (E1) loop
5502                               if Is_Subprogram (E1)
5503                                 and then Present
5504                                            (Abstract_Interface_Alias (E1))
5505                                 and then Alias (E1) = E
5506                               then
5507                                  Set_Alias (E1, S);
5508                               end if;
5509
5510                               E1 := Homonym (E1);
5511                            end loop;
5512                         end;
5513
5514                      else
5515                         Check_Dispatching_Operation (S, Empty);
5516                      end if;
5517
5518                      Maybe_Primitive_Operation (Is_Overriding => True);
5519                      goto Check_Inequality;
5520                   end;
5521
5522                --  Apparent redeclarations in instances can occur when two
5523                --  formal types get the same actual type. The subprograms in
5524                --  in the instance are legal,  even if not callable from the
5525                --  outside. Calls from within are disambiguated elsewhere.
5526                --  For dispatching operations in the visible part, the usual
5527                --  rules apply, and operations with the same profile are not
5528                --  legal (B830001).
5529
5530                elsif (In_Instance_Visible_Part
5531                        and then not Is_Dispatching_Operation (E))
5532                  or else In_Instance_Not_Visible
5533                then
5534                   null;
5535
5536                --  Here we have a real error (identical profile)
5537
5538                else
5539                   Error_Msg_Sloc := Sloc (E);
5540
5541                   --  Avoid cascaded errors if the entity appears in
5542                   --  subsequent calls.
5543
5544                   Set_Scope (S, Current_Scope);
5545
5546                   Error_Msg_N ("& conflicts with declaration#", S);
5547
5548                   if Is_Generic_Instance (S)
5549                     and then not Has_Completion (E)
5550                   then
5551                      Error_Msg_N
5552                        ("\instantiation cannot provide body for it", S);
5553                   end if;
5554
5555                   return;
5556                end if;
5557
5558             else
5559                --  If one subprogram has an access parameter and the other
5560                --  a parameter of an access type, calls to either might be
5561                --  ambiguous. Verify that parameters match except for the
5562                --  access parameter.
5563
5564                if May_Hide_Profile then
5565                   declare
5566                      F1    : Entity_Id;
5567                      F2    : Entity_Id;
5568                   begin
5569                      F1 := First_Formal (S);
5570                      F2 := First_Formal (E);
5571                      while Present (F1) and then Present (F2) loop
5572                         if Is_Access_Type (Etype (F1)) then
5573                            if not Is_Access_Type (Etype (F2))
5574                               or else not Conforming_Types
5575                                 (Designated_Type (Etype (F1)),
5576                                  Designated_Type (Etype (F2)),
5577                                  Type_Conformant)
5578                            then
5579                               May_Hide_Profile := False;
5580                            end if;
5581
5582                         elsif
5583                           not Conforming_Types
5584                             (Etype (F1), Etype (F2), Type_Conformant)
5585                         then
5586                            May_Hide_Profile := False;
5587                         end if;
5588
5589                         Next_Formal (F1);
5590                         Next_Formal (F2);
5591                      end loop;
5592
5593                      if May_Hide_Profile
5594                        and then No (F1)
5595                        and then No (F2)
5596                      then
5597                         Error_Msg_NE ("calls to& may be ambiguous?", S, S);
5598                      end if;
5599                   end;
5600                end if;
5601             end if;
5602
5603             Prev_Vis := E;
5604             E := Homonym (E);
5605          end loop;
5606
5607          --  On exit, we know that S is a new entity
5608
5609          Enter_Overloaded_Entity (S);
5610          Maybe_Primitive_Operation;
5611          Check_Overriding_Indicator (S, Does_Override);
5612
5613          --  If S is a derived operation for an untagged type then by
5614          --  definition it's not a dispatching operation (even if the parent
5615          --  operation was dispatching), so we don't call
5616          --  Check_Dispatching_Operation in that case.
5617
5618          if No (Derived_Type)
5619            or else Is_Tagged_Type (Derived_Type)
5620          then
5621             Check_Dispatching_Operation (S, Empty);
5622          end if;
5623       end if;
5624
5625       --  If this is a user-defined equality operator that is not a derived
5626       --  subprogram, create the corresponding inequality. If the operation is
5627       --  dispatching, the expansion is done elsewhere, and we do not create
5628       --  an explicit inequality operation.
5629
5630       <<Check_Inequality>>
5631          if Chars (S) = Name_Op_Eq
5632            and then Etype (S) = Standard_Boolean
5633            and then Present (Parent (S))
5634            and then not Is_Dispatching_Operation (S)
5635          then
5636             Make_Inequality_Operator (S);
5637          end if;
5638    end New_Overloaded_Entity;
5639
5640    ---------------------
5641    -- Process_Formals --
5642    ---------------------
5643
5644    procedure Process_Formals
5645      (T           : List_Id;
5646       Related_Nod : Node_Id)
5647    is
5648       Param_Spec  : Node_Id;
5649       Formal      : Entity_Id;
5650       Formal_Type : Entity_Id;
5651       Default     : Node_Id;
5652       Ptype       : Entity_Id;
5653
5654       function Is_Class_Wide_Default (D : Node_Id) return Boolean;
5655       --  Check whether the default has a class-wide type. After analysis the
5656       --  default has the type of the formal, so we must also check explicitly
5657       --  for an access attribute.
5658
5659       ---------------------------
5660       -- Is_Class_Wide_Default --
5661       ---------------------------
5662
5663       function Is_Class_Wide_Default (D : Node_Id) return Boolean is
5664       begin
5665          return Is_Class_Wide_Type (Designated_Type (Etype (D)))
5666            or else (Nkind (D) =  N_Attribute_Reference
5667                       and then Attribute_Name (D) = Name_Access
5668                       and then Is_Class_Wide_Type (Etype (Prefix (D))));
5669       end Is_Class_Wide_Default;
5670
5671    --  Start of processing for Process_Formals
5672
5673    begin
5674       --  In order to prevent premature use of the formals in the same formal
5675       --  part, the Ekind is left undefined until all default expressions are
5676       --  analyzed. The Ekind is established in a separate loop at the end.
5677
5678       Param_Spec := First (T);
5679
5680       while Present (Param_Spec) loop
5681
5682          Formal := Defining_Identifier (Param_Spec);
5683          Enter_Name (Formal);
5684
5685          --  Case of ordinary parameters
5686
5687          if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
5688             Find_Type (Parameter_Type (Param_Spec));
5689             Ptype := Parameter_Type (Param_Spec);
5690
5691             if Ptype = Error then
5692                goto Continue;
5693             end if;
5694
5695             Formal_Type := Entity (Ptype);
5696
5697             if Ekind (Formal_Type) = E_Incomplete_Type
5698               or else (Is_Class_Wide_Type (Formal_Type)
5699                         and then Ekind (Root_Type (Formal_Type)) =
5700                                                          E_Incomplete_Type)
5701             then
5702                --  Ada 2005 (AI-326): Tagged incomplete types allowed
5703
5704                if Is_Tagged_Type (Formal_Type) then
5705                   null;
5706
5707                elsif Nkind (Parent (T)) /= N_Access_Function_Definition
5708                  and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
5709                then
5710                   Error_Msg_N ("invalid use of incomplete type", Param_Spec);
5711                end if;
5712
5713             elsif Ekind (Formal_Type) = E_Void then
5714                Error_Msg_NE ("premature use of&",
5715                  Parameter_Type (Param_Spec), Formal_Type);
5716             end if;
5717
5718             --  Ada 2005 (AI-231): Create and decorate an internal subtype
5719             --  declaration corresponding to the null-excluding type of the
5720             --  formal in the enclosing scope. Finally, replace the parameter
5721             --  type of the formal with the internal subtype.
5722
5723             if Ada_Version >= Ada_05
5724               and then Is_Access_Type (Formal_Type)
5725               and then Null_Exclusion_Present (Param_Spec)
5726             then
5727                if Can_Never_Be_Null (Formal_Type)
5728                  and then Comes_From_Source (Related_Nod)
5729                then
5730                   Error_Msg_N
5731                     ("null exclusion must apply to a type that does not "
5732                        & "exclude null ('R'M 3.10 (14)", Related_Nod);
5733                end if;
5734
5735                Formal_Type :=
5736                  Create_Null_Excluding_Itype
5737                    (T           => Formal_Type,
5738                     Related_Nod => Related_Nod,
5739                     Scope_Id    => Scope (Current_Scope));
5740             end if;
5741
5742          --  An access formal type
5743
5744          else
5745             Formal_Type :=
5746               Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
5747
5748             --  Ada 2005 (AI-254)
5749
5750             declare
5751                AD : constant Node_Id :=
5752                       Access_To_Subprogram_Definition
5753                         (Parameter_Type (Param_Spec));
5754             begin
5755                if Present (AD) and then Protected_Present (AD) then
5756                   Formal_Type :=
5757                     Replace_Anonymous_Access_To_Protected_Subprogram
5758                       (Param_Spec, Formal_Type);
5759                end if;
5760             end;
5761          end if;
5762
5763          Set_Etype (Formal, Formal_Type);
5764          Default := Expression (Param_Spec);
5765
5766          if Present (Default) then
5767             if Out_Present (Param_Spec) then
5768                Error_Msg_N
5769                  ("default initialization only allowed for IN parameters",
5770                   Param_Spec);
5771             end if;
5772
5773             --  Do the special preanalysis of the expression (see section on
5774             --  "Handling of Default Expressions" in the spec of package Sem).
5775
5776             Analyze_Per_Use_Expression (Default, Formal_Type);
5777
5778             --  Check that the designated type of an access parameter's default
5779             --  is not a class-wide type unless the parameter's designated type
5780             --  is also class-wide.
5781
5782             if Ekind (Formal_Type) = E_Anonymous_Access_Type
5783               and then not From_With_Type (Formal_Type)
5784               and then Is_Class_Wide_Default (Default)
5785               and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
5786             then
5787                Error_Msg_N
5788                  ("access to class-wide expression not allowed here", Default);
5789             end if;
5790          end if;
5791
5792          --  Ada 2005 (AI-231): Static checks
5793
5794          if Ada_Version >= Ada_05
5795            and then Is_Access_Type (Etype (Formal))
5796            and then Can_Never_Be_Null (Etype (Formal))
5797          then
5798             Null_Exclusion_Static_Checks (Param_Spec);
5799          end if;
5800
5801       <<Continue>>
5802          Next (Param_Spec);
5803       end loop;
5804
5805       --  If this is the formal part of a function specification, analyze the
5806       --  subtype mark in the context where the formals are visible but not
5807       --  yet usable, and may hide outer homographs.
5808
5809       if Nkind (Related_Nod) = N_Function_Specification then
5810          Analyze_Return_Type (Related_Nod);
5811       end if;
5812
5813       --  Now set the kind (mode) of each formal
5814
5815       Param_Spec := First (T);
5816
5817       while Present (Param_Spec) loop
5818          Formal := Defining_Identifier (Param_Spec);
5819          Set_Formal_Mode (Formal);
5820
5821          if Ekind (Formal) = E_In_Parameter then
5822             Set_Default_Value (Formal, Expression (Param_Spec));
5823
5824             if Present (Expression (Param_Spec)) then
5825                Default :=  Expression (Param_Spec);
5826
5827                if Is_Scalar_Type (Etype (Default)) then
5828                   if Nkind
5829                        (Parameter_Type (Param_Spec)) /= N_Access_Definition
5830                   then
5831                      Formal_Type := Entity (Parameter_Type (Param_Spec));
5832
5833                   else
5834                      Formal_Type := Access_Definition
5835                        (Related_Nod, Parameter_Type (Param_Spec));
5836                   end if;
5837
5838                   Apply_Scalar_Range_Check (Default, Formal_Type);
5839                end if;
5840             end if;
5841          end if;
5842
5843          Next (Param_Spec);
5844       end loop;
5845
5846    end Process_Formals;
5847
5848    ----------------------------
5849    -- Reference_Body_Formals --
5850    ----------------------------
5851
5852    procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is
5853       Fs : Entity_Id;
5854       Fb : Entity_Id;
5855
5856    begin
5857       if Error_Posted (Spec) then
5858          return;
5859       end if;
5860
5861       Fs := First_Formal (Spec);
5862       Fb := First_Formal (Bod);
5863
5864       while Present (Fs) loop
5865          Generate_Reference (Fs, Fb, 'b');
5866
5867          if Style_Check then
5868             Style.Check_Identifier (Fb, Fs);
5869          end if;
5870
5871          Set_Spec_Entity (Fb, Fs);
5872          Set_Referenced (Fs, False);
5873          Next_Formal (Fs);
5874          Next_Formal (Fb);
5875       end loop;
5876    end Reference_Body_Formals;
5877
5878    -------------------------
5879    -- Set_Actual_Subtypes --
5880    -------------------------
5881
5882    procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
5883       Loc            : constant Source_Ptr := Sloc (N);
5884       Decl           : Node_Id;
5885       Formal         : Entity_Id;
5886       T              : Entity_Id;
5887       First_Stmt     : Node_Id := Empty;
5888       AS_Needed      : Boolean;
5889
5890    begin
5891       --  If this is an emtpy initialization procedure, no need to create
5892       --  actual subtypes (small optimization).
5893
5894       if Ekind (Subp) = E_Procedure
5895         and then Is_Null_Init_Proc (Subp)
5896       then
5897          return;
5898       end if;
5899
5900       Formal := First_Formal (Subp);
5901       while Present (Formal) loop
5902          T := Etype (Formal);
5903
5904          --  We never need an actual subtype for a constrained formal
5905
5906          if Is_Constrained (T) then
5907             AS_Needed := False;
5908
5909          --  If we have unknown discriminants, then we do not need an actual
5910          --  subtype, or more accurately we cannot figure it out! Note that
5911          --  all class-wide types have unknown discriminants.
5912
5913          elsif Has_Unknown_Discriminants (T) then
5914             AS_Needed := False;
5915
5916          --  At this stage we have an unconstrained type that may need an
5917          --  actual subtype. For sure the actual subtype is needed if we have
5918          --  an unconstrained array type.
5919
5920          elsif Is_Array_Type (T) then
5921             AS_Needed := True;
5922
5923          --  The only other case needing an actual subtype is an unconstrained
5924          --  record type which is an IN parameter (we cannot generate actual
5925          --  subtypes for the OUT or IN OUT case, since an assignment can
5926          --  change the discriminant values. However we exclude the case of
5927          --  initialization procedures, since discriminants are handled very
5928          --  specially in this context, see the section entitled "Handling of
5929          --  Discriminants" in Einfo.
5930
5931          --  We also exclude the case of Discrim_SO_Functions (functions used
5932          --  in front end layout mode for size/offset values), since in such
5933          --  functions only discriminants are referenced, and not only are such
5934          --  subtypes not needed, but they cannot always be generated, because
5935          --  of order of elaboration issues.
5936
5937          elsif Is_Record_Type (T)
5938            and then Ekind (Formal) = E_In_Parameter
5939            and then Chars (Formal) /= Name_uInit
5940            and then not Is_Unchecked_Union (T)
5941            and then not Is_Discrim_SO_Function (Subp)
5942          then
5943             AS_Needed := True;
5944
5945          --  All other cases do not need an actual subtype
5946
5947          else
5948             AS_Needed := False;
5949          end if;
5950
5951          --  Generate actual subtypes for unconstrained arrays and
5952          --  unconstrained discriminated records.
5953
5954          if AS_Needed then
5955             if Nkind (N) = N_Accept_Statement then
5956
5957                --  If expansion is active, The formal is replaced by a local
5958                --  variable that renames the corresponding entry of the
5959                --  parameter block, and it is this local variable that may
5960                --  require an actual subtype.
5961
5962                if Expander_Active then
5963                   Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
5964                else
5965                   Decl := Build_Actual_Subtype (T, Formal);
5966                end if;
5967
5968                if Present (Handled_Statement_Sequence (N)) then
5969                   First_Stmt :=
5970                     First (Statements (Handled_Statement_Sequence (N)));
5971                   Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
5972                   Mark_Rewrite_Insertion (Decl);
5973                else
5974                   --  If the accept statement has no body, there will be no
5975                   --  reference to the actuals, so no need to compute actual
5976                   --  subtypes.
5977
5978                   return;
5979                end if;
5980
5981             else
5982                Decl := Build_Actual_Subtype (T, Formal);
5983                Prepend (Decl, Declarations (N));
5984                Mark_Rewrite_Insertion (Decl);
5985             end if;
5986
5987             --  The declaration uses the bounds of an existing object, and
5988             --  therefore needs no constraint checks.
5989
5990             Analyze (Decl, Suppress => All_Checks);
5991
5992             --  We need to freeze manually the generated type when it is
5993             --  inserted anywhere else than in a declarative part.
5994
5995             if Present (First_Stmt) then
5996                Insert_List_Before_And_Analyze (First_Stmt,
5997                  Freeze_Entity (Defining_Identifier (Decl), Loc));
5998             end if;
5999
6000             if Nkind (N) = N_Accept_Statement
6001               and then Expander_Active
6002             then
6003                Set_Actual_Subtype (Renamed_Object (Formal),
6004                  Defining_Identifier (Decl));
6005             else
6006                Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
6007             end if;
6008          end if;
6009
6010          Next_Formal (Formal);
6011       end loop;
6012    end Set_Actual_Subtypes;
6013
6014    ---------------------
6015    -- Set_Formal_Mode --
6016    ---------------------
6017
6018    procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
6019       Spec : constant Node_Id := Parent (Formal_Id);
6020
6021    begin
6022       --  Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
6023       --  since we ensure that corresponding actuals are always valid at the
6024       --  point of the call.
6025
6026       if Out_Present (Spec) then
6027          if Ekind (Scope (Formal_Id)) = E_Function
6028            or else Ekind (Scope (Formal_Id)) = E_Generic_Function
6029          then
6030             Error_Msg_N ("functions can only have IN parameters", Spec);
6031             Set_Ekind (Formal_Id, E_In_Parameter);
6032
6033          elsif In_Present (Spec) then
6034             Set_Ekind (Formal_Id, E_In_Out_Parameter);
6035
6036          else
6037             Set_Ekind               (Formal_Id, E_Out_Parameter);
6038             Set_Never_Set_In_Source (Formal_Id, True);
6039             Set_Is_True_Constant    (Formal_Id, False);
6040             Set_Current_Value       (Formal_Id, Empty);
6041          end if;
6042
6043       else
6044          Set_Ekind (Formal_Id, E_In_Parameter);
6045       end if;
6046
6047       --  Set Is_Known_Non_Null for access parameters since the language
6048       --  guarantees that access parameters are always non-null. We also set
6049       --  Can_Never_Be_Null, since there is no way to change the value.
6050
6051       if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
6052
6053          --  Ada 2005 (AI-231): In Ada95, access parameters are always non-
6054          --  null; In Ada 2005, only if then null_exclusion is explicit.
6055
6056          if Ada_Version < Ada_05
6057            or else Can_Never_Be_Null (Etype (Formal_Id))
6058          then
6059             Set_Is_Known_Non_Null (Formal_Id);
6060             Set_Can_Never_Be_Null (Formal_Id);
6061          end if;
6062
6063       --  Ada 2005 (AI-231): Null-exclusion access subtype
6064
6065       elsif Is_Access_Type (Etype (Formal_Id))
6066         and then Can_Never_Be_Null (Etype (Formal_Id))
6067       then
6068          Set_Is_Known_Non_Null (Formal_Id);
6069       end if;
6070
6071       Set_Mechanism (Formal_Id, Default_Mechanism);
6072       Set_Formal_Validity (Formal_Id);
6073    end Set_Formal_Mode;
6074
6075    -------------------------
6076    -- Set_Formal_Validity --
6077    -------------------------
6078
6079    procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
6080    begin
6081       --  If no validity checking, then we cannot assume anything about the
6082       --  validity of parameters, since we do not know there is any checking
6083       --  of the validity on the call side.
6084
6085       if not Validity_Checks_On then
6086          return;
6087
6088       --  If validity checking for parameters is enabled, this means we are
6089       --  not supposed to make any assumptions about argument values.
6090
6091       elsif Validity_Check_Parameters then
6092          return;
6093
6094       --  If we are checking in parameters, we will assume that the caller is
6095       --  also checking parameters, so we can assume the parameter is valid.
6096
6097       elsif Ekind (Formal_Id) = E_In_Parameter
6098         and then Validity_Check_In_Params
6099       then
6100          Set_Is_Known_Valid (Formal_Id, True);
6101
6102       --  Similar treatment for IN OUT parameters
6103
6104       elsif Ekind (Formal_Id) = E_In_Out_Parameter
6105         and then Validity_Check_In_Out_Params
6106       then
6107          Set_Is_Known_Valid (Formal_Id, True);
6108       end if;
6109    end Set_Formal_Validity;
6110
6111    ------------------------
6112    -- Subtype_Conformant --
6113    ------------------------
6114
6115    function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
6116       Result : Boolean;
6117    begin
6118       Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result);
6119       return Result;
6120    end Subtype_Conformant;
6121
6122    ---------------------
6123    -- Type_Conformant --
6124    ---------------------
6125
6126    function Type_Conformant
6127      (New_Id                   : Entity_Id;
6128       Old_Id                   : Entity_Id;
6129       Skip_Controlling_Formals : Boolean := False) return Boolean
6130    is
6131       Result : Boolean;
6132    begin
6133       May_Hide_Profile := False;
6134
6135       Check_Conformance
6136         (New_Id, Old_Id, Type_Conformant, False, Result,
6137          Skip_Controlling_Formals => Skip_Controlling_Formals);
6138       return Result;
6139    end Type_Conformant;
6140
6141    -------------------------------
6142    -- Valid_Operator_Definition --
6143    -------------------------------
6144
6145    procedure Valid_Operator_Definition (Designator : Entity_Id) is
6146       N    : Integer := 0;
6147       F    : Entity_Id;
6148       Id   : constant Name_Id := Chars (Designator);
6149       N_OK : Boolean;
6150
6151    begin
6152       F := First_Formal (Designator);
6153       while Present (F) loop
6154          N := N + 1;
6155
6156          if Present (Default_Value (F)) then
6157             Error_Msg_N
6158               ("default values not allowed for operator parameters",
6159                Parent (F));
6160          end if;
6161
6162          Next_Formal (F);
6163       end loop;
6164
6165       --  Verify that user-defined operators have proper number of arguments
6166       --  First case of operators which can only be unary
6167
6168       if Id = Name_Op_Not
6169         or else Id = Name_Op_Abs
6170       then
6171          N_OK := (N = 1);
6172
6173       --  Case of operators which can be unary or binary
6174
6175       elsif Id = Name_Op_Add
6176         or Id = Name_Op_Subtract
6177       then
6178          N_OK := (N in 1 .. 2);
6179
6180       --  All other operators can only be binary
6181
6182       else
6183          N_OK := (N = 2);
6184       end if;
6185
6186       if not N_OK then
6187          Error_Msg_N
6188            ("incorrect number of arguments for operator", Designator);
6189       end if;
6190
6191       if Id = Name_Op_Ne
6192         and then Base_Type (Etype (Designator)) = Standard_Boolean
6193         and then not Is_Intrinsic_Subprogram (Designator)
6194       then
6195          Error_Msg_N
6196             ("explicit definition of inequality not allowed", Designator);
6197       end if;
6198    end Valid_Operator_Definition;
6199
6200 end Sem_Ch6;