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-2002, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Expander; use Expander;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Freeze;   use Freeze;
  36 with Lib.Xref; use Lib.Xref;
  37 with Namet;    use Namet;
  38 with Lib;      use Lib;
  39 with Nlists;   use Nlists;
  40 with Nmake;    use Nmake;
  41 with Opt;      use Opt;
  42 with Output;   use Output;
  43 with Rtsfind;  use Rtsfind;
  44 with Sem;      use Sem;
  45 with Sem_Cat;  use Sem_Cat;
  46 with Sem_Ch3;  use Sem_Ch3;
  47 with Sem_Ch4;  use Sem_Ch4;
  48 with Sem_Ch5;  use Sem_Ch5;
  49 with Sem_Ch8;  use Sem_Ch8;
  50 with Sem_Ch12; use Sem_Ch12;
  51 with Sem_Disp; use Sem_Disp;
  52 with Sem_Dist; use Sem_Dist;
  53 with Sem_Elim; use Sem_Elim;
  54 with Sem_Eval; use Sem_Eval;
  55 with Sem_Mech; use Sem_Mech;
  56 with Sem_Prag; use Sem_Prag;
  57 with Sem_Res;  use Sem_Res;
  58 with Sem_Util; use Sem_Util;
  59 with Sem_Type; use Sem_Type;
  60 with Sem_Warn; use Sem_Warn;
  61 with Sinput;   use Sinput;
  62 with Stand;    use Stand;
  63 with Sinfo;    use Sinfo;
  64 with Sinfo.CN; use Sinfo.CN;
  65 with Snames;   use Snames;
  66 with Stringt;  use Stringt;
  67 with Style;
  68 with Stylesw;  use Stylesw;
  69 with Tbuild;   use Tbuild;
  70 with Uintp;    use Uintp;
  71 with Urealp;   use Urealp;
  72 with Validsw;  use Validsw;
  73
  74 package body Sem_Ch6 is
  75
  76    -----------------------
  77    -- Local Subprograms --
  78    -----------------------
  79
  80    procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
  81    --  Analyze a generic subprogram body
  82
  83    function Build_Body_To_Inline
  84      (N         : Node_Id;
  85       Subp      : Entity_Id;
  86       Orig_Body : Node_Id)
  87       return      Boolean;
  88    --  If a subprogram has pragma Inline and inlining is active, use generic
  89    --  machinery to build an unexpanded body for the subprogram. This body is
  90    --  subsequenty used for inline expansions at call sites. If subprogram can
  91    --  be inlined (depending on size and nature of local declarations) this
  92    --  function returns true. Otherwise subprogram body is treated normally.
  93
  94    type Conformance_Type is
  95      (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
  96    --  Conformance type used for following call, meaning matches the
  97    --  RM definitions of the corresponding terms.
  98
  99    procedure Check_Conformance
 100      (New_Id   : Entity_Id;
 101       Old_Id   : Entity_Id;
 102       Ctype    : Conformance_Type;
 103       Errmsg   : Boolean;
 104       Conforms : out Boolean;
 105       Err_Loc  : Node_Id := Empty;
 106       Get_Inst : Boolean := False);
 107    --  Given two entities, this procedure checks that the profiles associated
 108    --  with these entities meet the conformance criterion given by the third
 109    --  parameter. If they conform, Conforms is set True and control returns
 110    --  to the caller. If they do not conform, Conforms is set to False, and
 111    --  in addition, if Errmsg is True on the call, proper messages are output
 112    --  to complain about the conformance failure. If Err_Loc is non_Empty
 113    --  the error messages are placed on Err_Loc, if Err_Loc is empty, then
 114    --  error messages are placed on the appropriate part of the construct
 115    --  denoted by New_Id. If Get_Inst is true, then this is a mode conformance
 116    --  against a formal access-to-subprogram type so Get_Instance_Of must
 117    --  be called.
 118
 119    procedure Check_Subprogram_Order (N : Node_Id);
 120    --  N is the N_Subprogram_Body node for a subprogram. This routine applies
 121    --  the alpha ordering rule for N if this ordering requirement applicable.
 122
 123    function Is_Non_Overriding_Operation
 124      (Prev_E : Entity_Id;
 125       New_E  : Entity_Id)
 126       return   Boolean;
 127    --  Enforce the rule given in 12.3(18): a private operation in an instance
 128    --  overrides an inherited operation only if the corresponding operation
 129    --  was overriding in the generic. This can happen for primitive operations
 130    --  of types derived (in the generic unit) from formal private or formal
 131    --  derived types.
 132
 133    procedure Check_Returns
 134      (HSS  : Node_Id;
 135       Mode : Character;
 136       Err  : out Boolean);
 137    --  Called to check for missing return statements in a function body,
 138    --  or for returns present in a procedure body which has No_Return set.
 139    --  L is the handled statement sequence for the subprogram body. This
 140    --  procedure checks all flow paths to make sure they either have a
 141    --  return (Mode = 'F') or do not have a return (Mode = 'P'). The flag
 142    --  Err is set if there are any control paths not explicitly terminated
 143    --  by a return in the function case, and is True otherwise.
 144
 145    function Conforming_Types
 146      (T1       : Entity_Id;
 147       T2       : Entity_Id;
 148       Ctype    : Conformance_Type;
 149       Get_Inst : Boolean := False)
 150       return     Boolean;
 151    --  Check that two formal parameter types conform, checking both
 152    --  for equality of base types, and where required statically
 153    --  matching subtypes, depending on the setting of Ctype.
 154
 155    procedure Enter_Overloaded_Entity (S : Entity_Id);
 156    --  This procedure makes S, a new overloaded entity, into the first
 157    --  visible entity with that name.
 158
 159    procedure Install_Entity (E : Entity_Id);
 160    --  Make single entity visible. Used for generic formals as well.
 161
 162    procedure Install_Formals (Id : Entity_Id);
 163    --  On entry to a subprogram body, make the formals visible. Note
 164    --  that simply placing the subprogram on the scope stack is not
 165    --  sufficient: the formals must become the current entities for
 166    --  their names.
 167
 168    procedure Make_Inequality_Operator (S : Entity_Id);
 169    --  Create the declaration for an inequality operator that is implicitly
 170    --  created by a user-defined equality operator that yields a boolean.
 171
 172    procedure May_Need_Actuals (Fun : Entity_Id);
 173    --  Flag functions that can be called without parameters, i.e. those that
 174    --  have no parameters, or those for which defaults exist for all parameters
 175
 176    procedure Set_Formal_Validity (Formal_Id : Entity_Id);
 177    --  Formal_Id is an formal parameter entity. This procedure deals with
 178    --  setting the proper validity status for this entity, which depends
 179    --  on the kind of parameter and the validity checking mode.
 180
 181    ---------------------------------------------
 182    -- Analyze_Abstract_Subprogram_Declaration --
 183    ---------------------------------------------
 184
 185    procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
 186       Designator : constant Entity_Id := Analyze_Spec (Specification (N));
 187       Scop       : constant Entity_Id := Current_Scope;
 188
 189    begin
 190       Generate_Definition (Designator);
 191       Set_Is_Abstract (Designator);
 192       New_Overloaded_Entity (Designator);
 193       Check_Delayed_Subprogram (Designator);
 194
 195       Set_Is_Pure (Designator,
 196         Is_Pure (Scop) and then Is_Library_Level_Entity (Designator));
 197       Set_Is_Remote_Call_Interface (
 198         Designator, Is_Remote_Call_Interface (Scop));
 199       Set_Is_Remote_Types (Designator, Is_Remote_Types (Scop));
 200
 201       if Ekind (Scope (Designator)) = E_Protected_Type then
 202          Error_Msg_N
 203            ("abstract subprogram not allowed in protected type", N);
 204       end if;
 205    end Analyze_Abstract_Subprogram_Declaration;
 206
 207    ----------------------------
 208    -- Analyze_Function_Call  --
 209    ----------------------------
 210
 211    procedure Analyze_Function_Call (N : Node_Id) is
 212       P      : constant Node_Id := Name (N);
 213       L      : constant List_Id := Parameter_Associations (N);
 214       Actual : Node_Id;
 215
 216    begin
 217       Analyze (P);
 218
 219       --  If error analyzing name, then set Any_Type as result type and return
 220
 221       if Etype (P) = Any_Type then
 222          Set_Etype (N, Any_Type);
 223          return;
 224       end if;
 225
 226       --  Otherwise analyze the parameters
 227
 228       if Present (L) then
 229          Actual := First (L);
 230
 231          while Present (Actual) loop
 232             Analyze (Actual);
 233             Check_Parameterless_Call (Actual);
 234             Next (Actual);
 235          end loop;
 236       end if;
 237
 238       Analyze_Call (N);
 239
 240    end Analyze_Function_Call;
 241
 242    -------------------------------------
 243    -- Analyze_Generic_Subprogram_Body --
 244    -------------------------------------
 245
 246    procedure Analyze_Generic_Subprogram_Body
 247      (N      : Node_Id;
 248       Gen_Id : Entity_Id)
 249    is
 250       Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
 251       Spec     : Node_Id;
 252       Kind     : constant Entity_Kind := Ekind (Gen_Id);
 253       Nam      : Entity_Id;
 254       New_N    : Node_Id;
 255
 256    begin
 257       --  Copy body and disable expansion while analyzing the generic
 258       --  For a stub, do not copy the stub (which would load the proper body),
 259       --  this will be done when the proper body is analyzed.
 260
 261       if Nkind (N) /= N_Subprogram_Body_Stub then
 262          New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
 263          Rewrite (N, New_N);
 264          Start_Generic;
 265       end if;
 266
 267       Spec := Specification (N);
 268
 269       --  Within the body of the generic, the subprogram is callable, and
 270       --  behaves like the corresponding non-generic unit.
 271
 272       Nam := Defining_Entity (Spec);
 273
 274       if Kind = E_Generic_Procedure
 275         and then Nkind (Spec) /= N_Procedure_Specification
 276       then
 277          Error_Msg_N ("invalid body for generic procedure ", Nam);
 278          return;
 279
 280       elsif Kind = E_Generic_Function
 281         and then Nkind (Spec) /= N_Function_Specification
 282       then
 283          Error_Msg_N ("invalid body for generic function ", Nam);
 284          return;
 285       end if;
 286
 287       Set_Corresponding_Body (Gen_Decl, Nam);
 288
 289       if Has_Completion (Gen_Id)
 290         and then Nkind (Parent (N)) /= N_Subunit
 291       then
 292          Error_Msg_N ("duplicate generic body", N);
 293          return;
 294       else
 295          Set_Has_Completion (Gen_Id);
 296       end if;
 297
 298       if Nkind (N) = N_Subprogram_Body_Stub then
 299          Set_Ekind (Defining_Entity (Specification (N)), Kind);
 300       else
 301          Set_Corresponding_Spec (N, Gen_Id);
 302       end if;
 303
 304       if Nkind (Parent (N)) = N_Compilation_Unit then
 305          Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));
 306       end if;
 307
 308       --  Make generic parameters immediately visible in the body. They are
 309       --  needed to process the formals declarations. Then make the formals
 310       --  visible in a separate step.
 311
 312       New_Scope (Gen_Id);
 313
 314       declare
 315          E         : Entity_Id;
 316          First_Ent : Entity_Id;
 317
 318       begin
 319          First_Ent := First_Entity (Gen_Id);
 320
 321          E := First_Ent;
 322          while Present (E) and then not Is_Formal (E) loop
 323             Install_Entity (E);
 324             Next_Entity (E);
 325          end loop;
 326
 327          Set_Use (Generic_Formal_Declarations (Gen_Decl));
 328
 329          --  Now generic formals are visible, and the specification can be
 330          --  analyzed, for subsequent conformance check.
 331
 332          Nam := Analyze_Spec (Spec);
 333
 334          if Nkind (N) = N_Subprogram_Body_Stub then
 335
 336             --  Nothing to do if no body to process
 337
 338             Set_Ekind (Nam, Kind);
 339             End_Scope;
 340             return;
 341          end if;
 342
 343          if Present (E) then
 344
 345             --  E is the first formal parameter, which must be the first
 346             --  entity in the subprogram body.
 347
 348             Set_First_Entity (Gen_Id, E);
 349
 350             --  Now make formal parameters visible
 351
 352             while Present (E) loop
 353                Install_Entity (E);
 354                Next_Formal (E);
 355             end loop;
 356          end if;
 357
 358          --  Visible generic entity is callable within its own body.
 359
 360          Set_Ekind (Gen_Id, Ekind (Nam));
 361          Set_Convention (Nam, Convention (Gen_Id));
 362          Set_Scope (Nam, Scope (Gen_Id));
 363          Check_Fully_Conformant (Nam, Gen_Id, Nam);
 364
 365          --  If this is a compilation unit, it must be made visible
 366          --  explicitly, because the compilation of the declaration,
 367          --  unlike other library unit declarations, does not. If it
 368          --  is not a unit, the following is redundant but harmless.
 369
 370          Set_Is_Immediately_Visible (Gen_Id);
 371
 372          Set_Actual_Subtypes (N, Current_Scope);
 373          Analyze_Declarations (Declarations (N));
 374          Check_Completion;
 375          Analyze (Handled_Statement_Sequence (N));
 376
 377          Save_Global_References (Original_Node (N));
 378
 379          --  Prior to exiting the scope, include generic formals again
 380          --  (if any are present) in the set of local entities.
 381
 382          if Present (First_Ent) then
 383             Set_First_Entity (Gen_Id, First_Ent);
 384          end if;
 385
 386       end;
 387
 388       End_Scope;
 389       Check_Subprogram_Order (N);
 390
 391       --  Outside of its body, unit is generic again.
 392
 393       Set_Ekind (Gen_Id, Kind);
 394       Set_Ekind (Nam, E_Subprogram_Body);
 395       Generate_Reference (Gen_Id, Nam, 'b');
 396       Style.Check_Identifier (Nam, Gen_Id);
 397       End_Generic;
 398
 399    end Analyze_Generic_Subprogram_Body;
 400
 401    -----------------------------
 402    -- Analyze_Operator_Symbol --
 403    -----------------------------
 404
 405    --  An operator symbol such as "+" or "and" may appear in context where
 406    --  the literal denotes an entity name, such as  "+"(x, y) or in a
 407    --  context when it is just a string, as in  (conjunction = "or"). In
 408    --  these cases the parser generates this node, and the semantics does
 409    --  the disambiguation. Other such case are actuals in an instantiation,
 410    --  the generic unit in an instantiation, and pragma arguments.
 411
 412    procedure Analyze_Operator_Symbol (N : Node_Id) is
 413       Par : constant Node_Id := Parent (N);
 414
 415    begin
 416       if        (Nkind (Par) = N_Function_Call and then N = Name (Par))
 417         or else  Nkind (Par) = N_Function_Instantiation
 418         or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
 419         or else (Nkind (Par) = N_Pragma_Argument_Association
 420                    and then not Is_Pragma_String_Literal (Par))
 421         or else  Nkind (Par) = N_Subprogram_Renaming_Declaration
 422         or else  (Nkind (Par) = N_Attribute_Reference
 423                    and then Attribute_Name (Par) /= Name_Value)
 424       then
 425          Find_Direct_Name (N);
 426
 427       else
 428          Change_Operator_Symbol_To_String_Literal (N);
 429          Analyze (N);
 430       end if;
 431    end Analyze_Operator_Symbol;
 432
 433    -----------------------------------
 434    -- Analyze_Parameter_Association --
 435    -----------------------------------
 436
 437    procedure Analyze_Parameter_Association (N : Node_Id) is
 438    begin
 439       Analyze (Explicit_Actual_Parameter (N));
 440    end Analyze_Parameter_Association;
 441
 442    ----------------------------
 443    -- Analyze_Procedure_Call --
 444    ----------------------------
 445
 446    procedure Analyze_Procedure_Call (N : Node_Id) is
 447       Loc     : constant Source_Ptr := Sloc (N);
 448       P       : constant Node_Id    := Name (N);
 449       Actuals : constant List_Id    := Parameter_Associations (N);
 450       Actual  : Node_Id;
 451       New_N   : Node_Id;
 452
 453       procedure Analyze_Call_And_Resolve;
 454       --  Do Analyze and Resolve calls for procedure call
 455
 456       procedure Analyze_Call_And_Resolve is
 457       begin
 458          if Nkind (N) = N_Procedure_Call_Statement then
 459             Analyze_Call (N);
 460             Resolve (N, Standard_Void_Type);
 461          else
 462             Analyze (N);
 463          end if;
 464       end Analyze_Call_And_Resolve;
 465
 466    --  Start of processing for Analyze_Procedure_Call
 467
 468    begin
 469       --  The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
 470       --  a procedure call or an entry call. The prefix may denote an access
 471       --  to subprogram type, in which case an implicit dereference applies.
 472       --  If the prefix is an indexed component (without implicit defererence)
 473       --  then the construct denotes a call to a member of an entire family.
 474       --  If the prefix is a simple name, it may still denote a call to a
 475       --  parameterless member of an entry family. Resolution of these various
 476       --  interpretations is delicate.
 477
 478       Analyze (P);
 479
 480       --  If error analyzing prefix, then set Any_Type as result and return
 481
 482       if Etype (P) = Any_Type then
 483          Set_Etype (N, Any_Type);
 484          return;
 485       end if;
 486
 487       --  Otherwise analyze the parameters
 488
 489       if Present (Actuals) then
 490          Actual := First (Actuals);
 491
 492          while Present (Actual) loop
 493             Analyze (Actual);
 494             Check_Parameterless_Call (Actual);
 495             Next (Actual);
 496          end loop;
 497       end if;
 498
 499       --  Special processing for Elab_Spec and Elab_Body calls
 500
 501       if Nkind (P) = N_Attribute_Reference
 502         and then (Attribute_Name (P) = Name_Elab_Spec
 503                    or else Attribute_Name (P) = Name_Elab_Body)
 504       then
 505          if Present (Actuals) then
 506             Error_Msg_N
 507               ("no parameters allowed for this call", First (Actuals));
 508             return;
 509          end if;
 510
 511          Set_Etype (N, Standard_Void_Type);
 512          Set_Analyzed (N);
 513
 514       elsif Is_Entity_Name (P)
 515         and then Is_Record_Type (Etype (Entity (P)))
 516         and then Remote_AST_I_Dereference (P)
 517       then
 518          return;
 519
 520       elsif Is_Entity_Name (P)
 521         and then Ekind (Entity (P)) /= E_Entry_Family
 522       then
 523          if Is_Access_Type (Etype (P))
 524            and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
 525            and then No (Actuals)
 526            and then Comes_From_Source (N)
 527          then
 528             Error_Msg_N ("missing explicit dereference in call", N);
 529          end if;
 530
 531          Analyze_Call_And_Resolve;
 532
 533       --  If the prefix is the simple name of an entry family, this is
 534       --  a parameterless call from within the task body itself.
 535
 536       elsif Is_Entity_Name (P)
 537         and then Nkind (P) = N_Identifier
 538         and then Ekind (Entity (P)) = E_Entry_Family
 539         and then Present (Actuals)
 540         and then No (Next (First (Actuals)))
 541       then
 542          --  Can be call to parameterless entry family. What appears to be
 543          --  the sole argument is in fact the entry index. Rewrite prefix
 544          --  of node accordingly. Source representation is unchanged by this
 545          --  transformation.
 546
 547          New_N :=
 548            Make_Indexed_Component (Loc,
 549              Prefix =>
 550                Make_Selected_Component (Loc,
 551                  Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
 552                  Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
 553              Expressions => Actuals);
 554          Set_Name (N, New_N);
 555          Set_Etype (New_N, Standard_Void_Type);
 556          Set_Parameter_Associations (N, No_List);
 557          Analyze_Call_And_Resolve;
 558
 559       elsif Nkind (P) = N_Explicit_Dereference then
 560          if Ekind (Etype (P)) = E_Subprogram_Type then
 561             Analyze_Call_And_Resolve;
 562          else
 563             Error_Msg_N ("expect access to procedure in call", P);
 564          end if;
 565
 566       --  The name can be a selected component or an indexed component
 567       --  that yields an access to subprogram. Such a prefix is legal if
 568       --  the call has parameter associations.
 569
 570       elsif Is_Access_Type (Etype (P))
 571         and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
 572       then
 573          if Present (Actuals) then
 574             Analyze_Call_And_Resolve;
 575          else
 576             Error_Msg_N ("missing explicit dereference in call ", N);
 577          end if;
 578
 579       --  If not an access to subprogram, then the prefix must resolve to
 580       --  the name of an entry, entry family, or protected operation.
 581
 582       --  For the case of a simple entry call, P is a selected component
 583       --  where the prefix is the task and the selector name is the entry.
 584       --  A call to a protected procedure will have the same syntax. If
 585       --  the protected object contains overloaded operations, the entity
 586       --  may appear as a function, the context will select the operation
 587       --  whose type is Void.
 588
 589       elsif Nkind (P) = N_Selected_Component
 590         and then (Ekind (Entity (Selector_Name (P))) = E_Entry
 591                     or else
 592                   Ekind (Entity (Selector_Name (P))) = E_Procedure
 593                     or else
 594                   Ekind (Entity (Selector_Name (P))) = E_Function)
 595       then
 596          Analyze_Call_And_Resolve;
 597
 598       elsif Nkind (P) = N_Selected_Component
 599         and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
 600         and then Present (Actuals)
 601         and then No (Next (First (Actuals)))
 602       then
 603          --  Can be call to parameterless entry family. What appears to be
 604          --  the sole argument is in fact the entry index. Rewrite prefix
 605          --  of node accordingly. Source representation is unchanged by this
 606          --  transformation.
 607
 608          New_N :=
 609            Make_Indexed_Component (Loc,
 610              Prefix => New_Copy (P),
 611              Expressions => Actuals);
 612          Set_Name (N, New_N);
 613          Set_Etype (New_N, Standard_Void_Type);
 614          Set_Parameter_Associations (N, No_List);
 615          Analyze_Call_And_Resolve;
 616
 617       --  For the case of a reference to an element of an entry family, P is
 618       --  an indexed component whose prefix is a selected component (task and
 619       --  entry family), and whose index is the entry family index.
 620
 621       elsif Nkind (P) = N_Indexed_Component
 622         and then Nkind (Prefix (P)) = N_Selected_Component
 623         and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
 624       then
 625          Analyze_Call_And_Resolve;
 626
 627       --  If the prefix is the name of an entry family, it is a call from
 628       --  within the task body itself.
 629
 630       elsif Nkind (P) = N_Indexed_Component
 631         and then Nkind (Prefix (P)) = N_Identifier
 632         and then Ekind (Entity (Prefix (P))) = E_Entry_Family
 633       then
 634          New_N :=
 635            Make_Selected_Component (Loc,
 636              Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
 637              Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
 638          Rewrite (Prefix (P), New_N);
 639          Analyze (P);
 640          Analyze_Call_And_Resolve;
 641
 642       --  Anything else is an error.
 643
 644       else
 645          Error_Msg_N ("Invalid procedure or entry call", N);
 646       end if;
 647    end Analyze_Procedure_Call;
 648
 649    ------------------------------
 650    -- Analyze_Return_Statement --
 651    ------------------------------
 652
 653    procedure Analyze_Return_Statement (N : Node_Id) is
 654       Loc      : constant Source_Ptr := Sloc (N);
 655       Expr     : Node_Id;
 656       Scope_Id : Entity_Id;
 657       Kind     : Entity_Kind;
 658       R_Type   : Entity_Id;
 659
 660    begin
 661       --  Find subprogram or accept statement enclosing the return statement
 662
 663       Scope_Id := Empty;
 664       for J in reverse 0 .. Scope_Stack.Last loop
 665          Scope_Id := Scope_Stack.Table (J).Entity;
 666          exit when Ekind (Scope_Id) /= E_Block and then
 667                    Ekind (Scope_Id) /= E_Loop;
 668       end loop;
 669
 670       pragma Assert (Present (Scope_Id));
 671
 672       Kind := Ekind (Scope_Id);
 673       Expr := Expression (N);
 674
 675       if Kind /= E_Function
 676         and then Kind /= E_Generic_Function
 677         and then Kind /= E_Procedure
 678         and then Kind /= E_Generic_Procedure
 679         and then Kind /= E_Entry
 680         and then Kind /= E_Entry_Family
 681       then
 682          Error_Msg_N ("illegal context for return statement", N);
 683
 684       elsif Present (Expr) then
 685          if Kind = E_Function or else Kind = E_Generic_Function then
 686             Set_Return_Present (Scope_Id);
 687             R_Type := Etype (Scope_Id);
 688             Set_Return_Type (N, R_Type);
 689             Analyze_And_Resolve (Expr, R_Type);
 690
 691             if (Is_Class_Wide_Type (Etype (Expr))
 692                  or else Is_Dynamically_Tagged (Expr))
 693               and then not Is_Class_Wide_Type (R_Type)
 694             then
 695                Error_Msg_N
 696                  ("dynamically tagged expression not allowed!", Expr);
 697             end if;
 698
 699             Apply_Constraint_Check (Expr, R_Type);
 700
 701             --  ??? A real run-time accessibility check is needed
 702             --  in cases involving dereferences of access parameters.
 703             --  For now we just check the static cases.
 704
 705             if Is_Return_By_Reference_Type (Etype (Scope_Id))
 706               and then Object_Access_Level (Expr)
 707                 > Subprogram_Access_Level (Scope_Id)
 708             then
 709                Rewrite (N,
 710                  Make_Raise_Program_Error (Loc,
 711                    Reason => PE_Accessibility_Check_Failed));
 712                Analyze (N);
 713
 714                Error_Msg_N
 715                  ("cannot return a local value by reference?", N);
 716                Error_Msg_NE
 717                  ("& will be raised at run time?!",
 718                   N, Standard_Program_Error);
 719             end if;
 720
 721          elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
 722             Error_Msg_N ("procedure cannot return value (use function)", N);
 723
 724          else
 725             Error_Msg_N ("accept statement cannot return value", N);
 726          end if;
 727
 728       --  No expression present
 729
 730       else
 731          if Kind = E_Function or Kind = E_Generic_Function then
 732             Error_Msg_N ("missing expression in return from function", N);
 733          end if;
 734
 735          if (Ekind (Scope_Id) = E_Procedure
 736               or else Ekind (Scope_Id) = E_Generic_Procedure)
 737            and then  No_Return (Scope_Id)
 738          then
 739             Error_Msg_N
 740               ("RETURN statement not allowed (No_Return)", N);
 741          end if;
 742       end if;
 743
 744       Check_Unreachable_Code (N);
 745    end Analyze_Return_Statement;
 746
 747    ------------------
 748    -- Analyze_Spec --
 749    ------------------
 750
 751    function Analyze_Spec (N : Node_Id) return Entity_Id is
 752       Designator : constant Entity_Id := Defining_Entity (N);
 753       Formals    : constant List_Id   := Parameter_Specifications (N);
 754       Typ        : Entity_Id;
 755
 756    begin
 757       Generate_Definition (Designator);
 758
 759       if Nkind (N) = N_Function_Specification then
 760          Set_Ekind (Designator, E_Function);
 761          Set_Mechanism (Designator, Default_Mechanism);
 762
 763          if Subtype_Mark (N) /= Error then
 764             Find_Type (Subtype_Mark (N));
 765             Typ := Entity (Subtype_Mark (N));
 766             Set_Etype (Designator, Typ);
 767
 768             if (Ekind (Typ) = E_Incomplete_Type
 769                  or else (Is_Class_Wide_Type (Typ)
 770                            and then
 771                              Ekind (Root_Type (Typ)) = E_Incomplete_Type))
 772             then
 773                Error_Msg_N
 774                  ("invalid use of incomplete type", Subtype_Mark (N));
 775             end if;
 776
 777          else
 778             Set_Etype (Designator, Any_Type);
 779          end if;
 780
 781       else
 782          Set_Ekind (Designator, E_Procedure);
 783          Set_Etype (Designator, Standard_Void_Type);
 784       end if;
 785
 786       if Present (Formals) then
 787          Set_Scope (Designator, Current_Scope);
 788          New_Scope (Designator);
 789          Process_Formals (Formals, N);
 790          End_Scope;
 791       end if;
 792
 793       if Nkind (N) = N_Function_Specification then
 794          if Nkind (Designator) = N_Defining_Operator_Symbol then
 795             Valid_Operator_Definition (Designator);
 796          end if;
 797
 798          May_Need_Actuals (Designator);
 799
 800          if Is_Abstract (Etype (Designator))
 801            and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration
 802          then
 803             Error_Msg_N
 804               ("function that returns abstract type must be abstract", N);
 805          end if;
 806       end if;
 807
 808       return Designator;
 809    end Analyze_Spec;
 810
 811    -----------------------------
 812    -- Analyze_Subprogram_Body --
 813    -----------------------------
 814
 815    --  This procedure is called for regular subprogram bodies, generic bodies,
 816    --  and for subprogram stubs of both kinds. In the case of stubs, only the
 817    --  specification matters, and is used to create a proper declaration for
 818    --  the subprogram, or to perform conformance checks.
 819
 820    procedure Analyze_Subprogram_Body (N : Node_Id) is
 821       Loc       : constant Source_Ptr := Sloc (N);
 822       Body_Spec : constant Node_Id    := Specification (N);
 823       Body_Id   : Entity_Id           := Defining_Entity (Body_Spec);
 824       Prev_Id   : constant Entity_Id  := Current_Entity_In_Scope (Body_Id);
 825
 826       HSS          : Node_Id;
 827       Spec_Id      : Entity_Id;
 828       Spec_Decl    : Node_Id   := Empty;
 829       Last_Formal  : Entity_Id := Empty;
 830       Conformant   : Boolean;
 831       Missing_Ret  : Boolean;
 832       Body_Deleted : Boolean := False;
 833       P_Ent        : Entity_Id;
 834
 835    begin
 836       if Debug_Flag_C then
 837          Write_Str ("====  Compiling subprogram body ");
 838          Write_Name (Chars (Body_Id));
 839          Write_Str (" from ");
 840          Write_Location (Loc);
 841          Write_Eol;
 842       end if;
 843
 844       Trace_Scope (N, Body_Id, " Analyze subprogram");
 845
 846       --  Generic subprograms are handled separately. They always have
 847       --  a generic specification. Determine whether current scope has
 848       --  a previous declaration.
 849
 850       --  If the subprogram body is defined within an instance of the
 851       --  same name, the instance appears as a package renaming, and
 852       --  will be hidden within the subprogram.
 853
 854       if Present (Prev_Id)
 855         and then not Is_Overloadable (Prev_Id)
 856         and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
 857                    or else Comes_From_Source (Prev_Id))
 858       then
 859          if Ekind (Prev_Id) = E_Generic_Procedure
 860            or else Ekind (Prev_Id) = E_Generic_Function
 861          then
 862             Spec_Id := Prev_Id;
 863             Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
 864             Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
 865
 866             Analyze_Generic_Subprogram_Body (N, Spec_Id);
 867             return;
 868
 869          else
 870             --  Previous entity conflicts with subprogram name.
 871             --  Attempting to enter name will post error.
 872
 873             Enter_Name (Body_Id);
 874             return;
 875          end if;
 876
 877       --  Non-generic case, find the subprogram declaration, if one was
 878       --  seen, or enter new overloaded entity in the current scope.
 879       --  If the current_entity is the body_id itself, the unit is being
 880       --  analyzed as part of the context of one of its subunits. No need
 881       --  to redo the analysis.
 882
 883       elsif Prev_Id = Body_Id
 884         and then Has_Completion (Body_Id)
 885       then
 886          return;
 887
 888       else
 889          Body_Id := Analyze_Spec (Body_Spec);
 890
 891          if Nkind (N) = N_Subprogram_Body_Stub
 892            or else No (Corresponding_Spec (N))
 893          then
 894             Spec_Id := Find_Corresponding_Spec (N);
 895
 896             --  If this is a duplicate body, no point in analyzing it
 897
 898             if Error_Posted (N) then
 899                return;
 900             end if;
 901
 902             --  A subprogram body should cause freezing of its own
 903             --  declaration, but if there was no previous explicit
 904             --  declaration, then the subprogram will get frozen too
 905             --  late (there may be code within the body that depends
 906             --  on the subprogram having been frozen, such as uses of
 907             --  extra formals), so we force it to be frozen here.
 908             --  Same holds if the body and the spec are compilation units.
 909
 910             if No (Spec_Id) then
 911                Freeze_Before (N, Body_Id);
 912
 913             elsif Nkind (Parent (N)) = N_Compilation_Unit then
 914                Freeze_Before (N, Spec_Id);
 915             end if;
 916          else
 917             Spec_Id := Corresponding_Spec (N);
 918          end if;
 919       end if;
 920
 921       --  Do not inline any subprogram that contains nested subprograms,
 922       --  since the backend inlining circuit seems to generate uninitialized
 923       --  references in this case. We know this happens in the case of front
 924       --  end ZCX support, but it also appears it can happen in other cases
 925       --  as well. The backend often rejects attempts to inline in the case
 926       --  of nested procedures anyway, so little if anything is lost by this.
 927
 928       --  Do not do this test if errors have been detected, because in some
 929       --  error cases, this code blows up, and we don't need it anyway if
 930       --  there have been errors, since we won't get to the linker anyway.
 931
 932       if Serious_Errors_Detected = 0 then
 933          P_Ent := Body_Id;
 934          loop
 935             P_Ent := Scope (P_Ent);
 936             exit when No (P_Ent) or else P_Ent = Standard_Standard;
 937
 938             if Is_Subprogram (P_Ent) and then Is_Inlined (P_Ent) then
 939                Set_Is_Inlined (P_Ent, False);
 940
 941                if Comes_From_Source (P_Ent)
 942                  and then Ineffective_Inline_Warnings
 943                  and then Has_Pragma_Inline (P_Ent)
 944                then
 945                   Error_Msg_NE
 946                     ("?pragma Inline for & ignored (has nested subprogram)",
 947                      Get_Rep_Pragma (P_Ent, Name_Inline), P_Ent);
 948                end if;
 949             end if;
 950          end loop;
 951       end if;
 952
 953       --  Case of fully private operation in the body of the protected type.
 954       --  We must create a declaration for the subprogram, in order to attach
 955       --  the protected subprogram that will be used in internal calls.
 956
 957       if No (Spec_Id)
 958         and then Comes_From_Source (N)
 959         and then Is_Protected_Type (Current_Scope)
 960       then
 961          declare
 962             Decl     : Node_Id;
 963             Plist    : List_Id;
 964             Formal   : Entity_Id;
 965             New_Spec : Node_Id;
 966
 967          begin
 968             Formal := First_Formal (Body_Id);
 969
 970             --  The protected operation always has at least one formal,
 971             --  namely the object itself, but it is only placed in the
 972             --  parameter list if expansion is enabled.
 973
 974             if Present (Formal)
 975               or else Expander_Active
 976             then
 977                Plist := New_List;
 978
 979             else
 980                Plist := No_List;
 981             end if;
 982
 983             while Present (Formal) loop
 984                Append
 985                  (Make_Parameter_Specification (Loc,
 986                    Defining_Identifier =>
 987                      Make_Defining_Identifier (Sloc (Formal),
 988                        Chars => Chars (Formal)),
 989                    In_Present  => In_Present (Parent (Formal)),
 990                    Out_Present => Out_Present (Parent (Formal)),
 991                    Parameter_Type =>
 992                      New_Reference_To (Etype (Formal), Loc),
 993                    Expression =>
 994                      New_Copy_Tree (Expression (Parent (Formal)))),
 995                  Plist);
 996
 997                Next_Formal (Formal);
 998             end loop;
 999
1000             if Nkind (Body_Spec) = N_Procedure_Specification then
1001                New_Spec :=
1002                  Make_Procedure_Specification (Loc,
1003                     Defining_Unit_Name =>
1004                       Make_Defining_Identifier (Sloc (Body_Id),
1005                         Chars => Chars (Body_Id)),
1006                     Parameter_Specifications => Plist);
1007             else
1008                New_Spec :=
1009                  Make_Function_Specification (Loc,
1010                     Defining_Unit_Name =>
1011                       Make_Defining_Identifier (Sloc (Body_Id),
1012                         Chars => Chars (Body_Id)),
1013                     Parameter_Specifications => Plist,
1014                     Subtype_Mark => New_Occurrence_Of (Etype (Body_Id), Loc));
1015             end if;
1016
1017             Decl :=
1018               Make_Subprogram_Declaration (Loc,
1019                 Specification => New_Spec);
1020             Insert_Before (N, Decl);
1021             Analyze (Decl);
1022             Spec_Id := Defining_Unit_Name (New_Spec);
1023             Set_Has_Completion (Spec_Id);
1024             Set_Convention (Spec_Id, Convention_Protected);
1025          end;
1026
1027       elsif Present (Spec_Id) then
1028          Spec_Decl := Unit_Declaration_Node (Spec_Id);
1029       end if;
1030
1031       --  Place subprogram on scope stack, and make formals visible. If there
1032       --  is a spec, the visible entity remains that of the spec.
1033
1034       if Present (Spec_Id) then
1035          Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
1036          Style.Check_Identifier (Body_Id, Spec_Id);
1037
1038          Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
1039          Set_Is_Child_Unit       (Body_Id, Is_Child_Unit       (Spec_Id));
1040
1041          if Is_Abstract (Spec_Id) then
1042             Error_Msg_N ("an abstract subprogram cannot have a body", N);
1043             return;
1044          else
1045             Set_Convention (Body_Id, Convention (Spec_Id));
1046             Set_Has_Completion (Spec_Id);
1047
1048             if Is_Protected_Type (Scope (Spec_Id)) then
1049                Set_Privals_Chain (Spec_Id, New_Elmt_List);
1050             end if;
1051
1052             --  If this is a body generated for a renaming, do not check for
1053             --  full conformance. The check is redundant, because the spec of
1054             --  the body is a copy of the spec in the renaming declaration,
1055             --  and the test can lead to spurious errors on nested defaults.
1056
1057             if Present (Spec_Decl)
1058               and then not Comes_From_Source (N)
1059               and then
1060                 (Nkind (Original_Node (Spec_Decl)) =
1061                                         N_Subprogram_Renaming_Declaration
1062                    or else (Present (Corresponding_Body (Spec_Decl))
1063                               and then
1064                                 Nkind (Unit_Declaration_Node
1065                                         (Corresponding_Body (Spec_Decl))) =
1066                                            N_Subprogram_Renaming_Declaration))
1067             then
1068                Conformant := True;
1069             else
1070                Check_Conformance
1071                  (Body_Id, Spec_Id,
1072                    Fully_Conformant, True, Conformant, Body_Id);
1073             end if;
1074
1075             --  If the body is not fully conformant, we have to decide if we
1076             --  should analyze it or not. If it has a really messed up profile
1077             --  then we probably should not analyze it, since we will get too
1078             --  many bogus messages.
1079
1080             --  Our decision is to go ahead in the non-fully conformant case
1081             --  only if it is at least mode conformant with the spec. Note
1082             --  that the call to Check_Fully_Conformant has issued the proper
1083             --  error messages to complain about the lack of conformance.
1084
1085             if not Conformant
1086               and then not Mode_Conformant (Body_Id, Spec_Id)
1087             then
1088                return;
1089             end if;
1090          end if;
1091
1092          --  Generate references from body formals to spec formals
1093          --  and also set the Spec_Entity fields for all formals. We
1094          --  do not set this reference count as a reference for the
1095          --  purposes of identifying unreferenced formals however.
1096
1097          if Spec_Id /= Body_Id then
1098             declare
1099                Fs : Entity_Id;
1100                Fb : Entity_Id;
1101
1102             begin
1103                Fs := First_Formal (Spec_Id);
1104                Fb := First_Formal (Body_Id);
1105                while Present (Fs) loop
1106                   Generate_Reference (Fs, Fb, 'b');
1107                   Style.Check_Identifier (Fb, Fs);
1108                   Set_Spec_Entity (Fb, Fs);
1109                   Set_Referenced (Fs, False);
1110                   Next_Formal (Fs);
1111                   Next_Formal (Fb);
1112                end loop;
1113             end;
1114          end if;
1115
1116          if Nkind (N) /= N_Subprogram_Body_Stub then
1117             Set_Corresponding_Spec (N, Spec_Id);
1118             Install_Formals (Spec_Id);
1119             Last_Formal := Last_Entity (Spec_Id);
1120             New_Scope (Spec_Id);
1121
1122             --  Make sure that the subprogram is immediately visible. For
1123             --  child units that have no separate spec this is indispensable.
1124             --  Otherwise it is safe albeit redundant.
1125
1126             Set_Is_Immediately_Visible (Spec_Id);
1127          end if;
1128
1129          Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id);
1130          Set_Ekind (Body_Id, E_Subprogram_Body);
1131          Set_Scope (Body_Id, Scope (Spec_Id));
1132
1133       --  Case of subprogram body with no previous spec
1134
1135       else
1136          if Style_Check
1137            and then Comes_From_Source (Body_Id)
1138            and then not Suppress_Style_Checks (Body_Id)
1139            and then not In_Instance
1140          then
1141             Style.Body_With_No_Spec (N);
1142          end if;
1143
1144          New_Overloaded_Entity (Body_Id);
1145
1146          if Nkind (N) /= N_Subprogram_Body_Stub then
1147             Set_Acts_As_Spec (N);
1148             Generate_Definition (Body_Id);
1149             Install_Formals (Body_Id);
1150             New_Scope (Body_Id);
1151          end if;
1152       end if;
1153
1154       --  If this is the proper body of a stub, we must verify that the stub
1155       --  conforms to the body, and to the previous spec if one was present.
1156       --  we know already that the body conforms to that spec. This test is
1157       --  only required for subprograms that come from source.
1158
1159       if Nkind (Parent (N)) = N_Subunit
1160         and then Comes_From_Source (N)
1161         and then not Error_Posted (Body_Id)
1162       then
1163          declare
1164             Conformant : Boolean := False;
1165             Old_Id     : Entity_Id :=
1166                            Defining_Entity
1167                              (Specification (Corresponding_Stub (Parent (N))));
1168
1169          begin
1170             if No (Spec_Id) then
1171                Check_Fully_Conformant (Body_Id, Old_Id);
1172
1173             else
1174                Check_Conformance
1175                  (Body_Id, Old_Id, Fully_Conformant, False, Conformant);
1176
1177                if not Conformant then
1178
1179                   --  The stub was taken to be a new declaration. Indicate
1180                   --  that it lacks a body.
1181
1182                   Set_Has_Completion (Old_Id, False);
1183                end if;
1184             end if;
1185          end;
1186       end if;
1187
1188       Set_Has_Completion (Body_Id);
1189       Check_Eliminated (Body_Id);
1190
1191       if Nkind (N) = N_Subprogram_Body_Stub then
1192          return;
1193
1194       elsif  Present (Spec_Id)
1195         and then Expander_Active
1196         and then (Is_Always_Inlined (Spec_Id)
1197                     or else (Has_Pragma_Inline (Spec_Id)
1198                               and then
1199                                 (Front_End_Inlining or else No_Run_Time)))
1200       then
1201          if Build_Body_To_Inline (N, Spec_Id, Copy_Separate_Tree (N)) then
1202             null;
1203          end if;
1204       end if;
1205
1206       --  Now we can go on to analyze the body
1207
1208       HSS := Handled_Statement_Sequence (N);
1209       Set_Actual_Subtypes (N, Current_Scope);
1210       Analyze_Declarations (Declarations (N));
1211       Check_Completion;
1212       Analyze (HSS);
1213       Process_End_Label (HSS, 't', Current_Scope);
1214       End_Scope;
1215       Check_Subprogram_Order (N);
1216
1217       --  If we have a separate spec, then the analysis of the declarations
1218       --  caused the entities in the body to be chained to the spec id, but
1219       --  we want them chained to the body id. Only the formal parameters
1220       --  end up chained to the spec id in this case.
1221
1222       if Present (Spec_Id) then
1223
1224          --  If a parent unit is categorized, the context of a subunit
1225          --  must conform to the categorization. Conversely, if a child
1226          --  unit is categorized, the parents themselves must conform.
1227
1228          if Nkind (Parent (N)) = N_Subunit then
1229             Validate_Categorization_Dependency (N, Spec_Id);
1230
1231          elsif Is_Child_Unit (Spec_Id) then
1232             Validate_Categorization_Dependency
1233               (Unit_Declaration_Node (Spec_Id), Spec_Id);
1234          end if;
1235
1236          if Present (Last_Formal) then
1237             Set_Next_Entity
1238               (Last_Entity (Body_Id), Next_Entity (Last_Formal));
1239             Set_Next_Entity (Last_Formal, Empty);
1240             Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
1241             Set_Last_Entity (Spec_Id, Last_Formal);
1242
1243          else
1244             Set_First_Entity (Body_Id, First_Entity (Spec_Id));
1245             Set_Last_Entity  (Body_Id, Last_Entity (Spec_Id));
1246             Set_First_Entity (Spec_Id, Empty);
1247             Set_Last_Entity  (Spec_Id, Empty);
1248          end if;
1249       end if;
1250
1251       --  If function, check return statements
1252
1253       if Nkind (Body_Spec) = N_Function_Specification then
1254          declare
1255             Id : Entity_Id;
1256
1257          begin
1258             if Present (Spec_Id) then
1259                Id := Spec_Id;
1260             else
1261                Id := Body_Id;
1262             end if;
1263
1264             if Return_Present (Id) then
1265                Check_Returns (HSS, 'F', Missing_Ret);
1266
1267                if Missing_Ret then
1268                   Set_Has_Missing_Return (Id);
1269                end if;
1270
1271             elsif not Is_Machine_Code_Subprogram (Id)
1272               and then not Body_Deleted
1273             then
1274                Error_Msg_N ("missing RETURN statement in function body", N);
1275             end if;
1276          end;
1277
1278       --  If procedure with No_Return, check returns
1279
1280       elsif Nkind (Body_Spec) = N_Procedure_Specification
1281         and then Present (Spec_Id)
1282         and then No_Return (Spec_Id)
1283       then
1284          Check_Returns (HSS, 'P', Missing_Ret);
1285       end if;
1286
1287       --  Don't worry about checking for variables that are never modified
1288       --  if the first statement of the body is a raise statement, since
1289       --  we assume this is some kind of stub. We ignore a label generated
1290       --  by the exception stuff for the purpose of this test.
1291
1292       declare
1293          Stm : Node_Id := First (Statements (HSS));
1294
1295       begin
1296          if Nkind (Stm) = N_Label then
1297             Next (Stm);
1298          end if;
1299
1300          if Nkind (Original_Node (Stm)) = N_Raise_Statement then
1301             return;
1302          end if;
1303       end;
1304
1305       --  Check for variables that are never modified
1306
1307       declare
1308          E1, E2 : Entity_Id;
1309
1310       begin
1311          --  If there is a separate spec, then transfer Not_Source_Assigned
1312          --  flags from out parameters to the corresponding entities in the
1313          --  body. The reason we do that is we want to post error flags on
1314          --  the body entities, not the spec entities.
1315
1316          if Present (Spec_Id) then
1317             E1 := First_Entity (Spec_Id);
1318
1319             while Present (E1) loop
1320                if Ekind (E1) = E_Out_Parameter then
1321                   E2 := First_Entity (Body_Id);
1322
1323                   loop
1324                      --  If no matching body entity, then we already had
1325                      --  a detected error of some kind, so just forget
1326                      --  about worrying about these warnings.
1327
1328                      if No (E2) then
1329                         return;
1330                      end if;
1331
1332                      exit when Chars (E1) = Chars (E2);
1333                      Next_Entity (E2);
1334                   end loop;
1335
1336                   Set_Not_Source_Assigned (E2, Not_Source_Assigned (E1));
1337                end if;
1338
1339                Next_Entity (E1);
1340             end loop;
1341          end if;
1342
1343          --  Check references in body unless it was deleted. Note that the
1344          --  check of Body_Deleted here is not just for efficiency, it is
1345          --  necessary to avoid junk warnings on formal parameters.
1346
1347          if not Body_Deleted then
1348             Check_References (Body_Id);
1349          end if;
1350       end;
1351    end Analyze_Subprogram_Body;
1352
1353    ------------------------------------
1354    -- Analyze_Subprogram_Declaration --
1355    ------------------------------------
1356
1357    procedure Analyze_Subprogram_Declaration (N : Node_Id) is
1358       Designator : constant Entity_Id := Analyze_Spec (Specification (N));
1359       Scop        : constant Entity_Id := Current_Scope;
1360
1361    --  Start of processing for Analyze_Subprogram_Declaration
1362
1363    begin
1364       Generate_Definition (Designator);
1365
1366       --  Check for RCI unit subprogram declarations against in-lined
1367       --  subprograms and subprograms having access parameter or limited
1368       --  parameter without Read and Write (RM E.2.3(12-13)).
1369
1370       Validate_RCI_Subprogram_Declaration (N);
1371
1372       Trace_Scope
1373         (N,
1374          Defining_Entity (N),
1375          " Analyze subprogram spec. ");
1376
1377       if Debug_Flag_C then
1378          Write_Str ("====  Compiling subprogram spec ");
1379          Write_Name (Chars (Designator));
1380          Write_Str (" from ");
1381          Write_Location (Sloc (N));
1382          Write_Eol;
1383       end if;
1384
1385       New_Overloaded_Entity (Designator);
1386       Check_Delayed_Subprogram (Designator);
1387       Set_Suppress_Elaboration_Checks
1388         (Designator, Elaboration_Checks_Suppressed (Designator));
1389
1390       if Scop /= Standard_Standard
1391         and then not Is_Child_Unit (Designator)
1392       then
1393          Set_Is_Pure (Designator,
1394            Is_Pure (Scop) and then Is_Library_Level_Entity (Designator));
1395          Set_Is_Remote_Call_Interface (
1396            Designator, Is_Remote_Call_Interface (Scop));
1397          Set_Is_Remote_Types (Designator, Is_Remote_Types (Scop));
1398
1399       else
1400          --  For a compilation unit, check for library-unit pragmas.
1401
1402          New_Scope (Designator);
1403          Set_Categorization_From_Pragmas (N);
1404          Validate_Categorization_Dependency (N, Designator);
1405          Pop_Scope;
1406       end if;
1407
1408       --  For a compilation unit, set body required. This flag will only be
1409       --  reset if a valid Import or Interface pragma is processed later on.
1410
1411       if Nkind (Parent (N)) = N_Compilation_Unit then
1412          Set_Body_Required (Parent (N), True);
1413       end if;
1414
1415       Check_Eliminated (Designator);
1416    end Analyze_Subprogram_Declaration;
1417
1418    --------------------------
1419    -- Build_Body_To_Inline --
1420    --------------------------
1421
1422    function Build_Body_To_Inline
1423      (N         : Node_Id;
1424       Subp      : Entity_Id;
1425       Orig_Body : Node_Id) return Boolean
1426    is
1427       Decl : constant Node_Id := Unit_Declaration_Node (Subp);
1428       Original_Body   : Node_Id;
1429       Body_To_Analyze : Node_Id;
1430       Max_Size        : constant := 10;
1431       Stat_Count      : Integer := 0;
1432
1433       function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
1434       --  Check for declarations that make inlining not worthwhile.
1435
1436       function Has_Excluded_Statement   (Stats : List_Id) return Boolean;
1437       --  Check for statements that make inlining not worthwhile: any
1438       --  tasking statement, nested at any level. Keep track of total
1439       --  number of elementary statements, as a measure of acceptable size.
1440
1441       function Has_Pending_Instantiation return Boolean;
1442       --  If some enclosing body contains instantiations that appear before
1443       --  the corresponding generic body, the enclosing body has a freeze node
1444       --  so that it can be elaborated after the generic itself. This might
1445       --  conflict with subsequent inlinings, so that it is unsafe to try to
1446       --  inline in such a case.
1447
1448       -------------------
1449       -- Cannot_Inline --
1450       -------------------
1451
1452       procedure Cannot_Inline (Msg : String; N : Node_Id);
1453       --  If subprogram has pragma Inline_Always, it is an error if
1454       --  it cannot be inlined. Otherwise, emit a warning.
1455
1456       procedure Cannot_Inline (Msg : String; N : Node_Id) is
1457       begin
1458          if Is_Always_Inlined (Subp) then
1459             Error_Msg_NE (Msg (1 .. Msg'Length - 1), N, Subp);
1460
1461          elsif Ineffective_Inline_Warnings then
1462             Error_Msg_NE (Msg, N, Subp);
1463          end if;
1464       end Cannot_Inline;
1465
1466       ------------------------------
1467       -- Has_Excluded_Declaration --
1468       ------------------------------
1469
1470       function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
1471          D : Node_Id;
1472
1473       begin
1474          D := First (Decls);
1475
1476          while Present (D) loop
1477             if        Nkind (D) = N_Function_Instantiation
1478               or else Nkind (D) = N_Protected_Type_Declaration
1479               or else Nkind (D) = N_Package_Declaration
1480               or else Nkind (D) = N_Package_Instantiation
1481               or else Nkind (D) = N_Subprogram_Body
1482               or else Nkind (D) = N_Procedure_Instantiation
1483               or else Nkind (D) = N_Task_Type_Declaration
1484             then
1485                Cannot_Inline
1486                  ("\declaration prevents front-end inlining of&?", D);
1487                return True;
1488             end if;
1489
1490             Next (D);
1491          end loop;
1492
1493          return False;
1494
1495       end Has_Excluded_Declaration;
1496
1497       ----------------------------
1498       -- Has_Excluded_Statement --
1499       ----------------------------
1500
1501       function Has_Excluded_Statement (Stats : List_Id) return Boolean is
1502          S : Node_Id;
1503          E : Node_Id;
1504
1505       begin
1506          S := First (Stats);
1507
1508          while Present (S) loop
1509             Stat_Count := Stat_Count + 1;
1510
1511             if Nkind (S) = N_Abort_Statement
1512               or else Nkind (S) = N_Asynchronous_Select
1513               or else Nkind (S) = N_Conditional_Entry_Call
1514               or else Nkind (S) = N_Delay_Relative_Statement
1515               or else Nkind (S) = N_Delay_Until_Statement
1516               or else Nkind (S) = N_Selective_Accept
1517               or else Nkind (S) = N_Timed_Entry_Call
1518             then
1519                Cannot_Inline
1520                  ("\statement prevents front-end inlining of&?", S);
1521                return True;
1522
1523             elsif Nkind (S) = N_Block_Statement then
1524                if Present (Declarations (S))
1525                  and then Has_Excluded_Declaration (Declarations (S))
1526                then
1527                   return True;
1528
1529                elsif Present (Handled_Statement_Sequence (S))
1530                   and then
1531                     (Present
1532                       (Exception_Handlers (Handled_Statement_Sequence (S)))
1533                      or else
1534                        Has_Excluded_Statement
1535                          (Statements (Handled_Statement_Sequence (S))))
1536                then
1537                   return True;
1538                end if;
1539
1540             elsif Nkind (S) = N_Case_Statement then
1541                E := First (Alternatives (S));
1542
1543                while Present (E) loop
1544                   if Has_Excluded_Statement (Statements (E)) then
1545                      return True;
1546                   end if;
1547
1548                   Next (E);
1549                end loop;
1550
1551             elsif Nkind (S) = N_If_Statement then
1552                if Has_Excluded_Statement (Then_Statements (S)) then
1553                   return True;
1554                end if;
1555
1556                if Present (Elsif_Parts (S)) then
1557                   E := First (Elsif_Parts (S));
1558
1559                   while Present (E) loop
1560                      if Has_Excluded_Statement (Then_Statements (E)) then
1561                         return True;
1562                      end if;
1563                      Next (E);
1564                   end loop;
1565                end if;
1566
1567                if Present (Else_Statements (S))
1568                  and then Has_Excluded_Statement (Else_Statements (S))
1569                then
1570                   return True;
1571                end if;
1572
1573             elsif Nkind (S) = N_Loop_Statement
1574               and then Has_Excluded_Statement (Statements (S))
1575             then
1576                return True;
1577             end if;
1578
1579             Next (S);
1580          end loop;
1581
1582          return False;
1583       end Has_Excluded_Statement;
1584
1585       -------------------------------
1586       -- Has_Pending_Instantiation --
1587       -------------------------------
1588
1589       function Has_Pending_Instantiation return Boolean is
1590          S : Entity_Id := Current_Scope;
1591
1592       begin
1593          while Present (S) loop
1594             if Is_Compilation_Unit (S)
1595               or else Is_Child_Unit (S)
1596             then
1597                return False;
1598             elsif Ekind (S) = E_Package
1599               and then Has_Forward_Instantiation (S)
1600             then
1601                return True;
1602             end if;
1603
1604             S := Scope (S);
1605          end loop;
1606
1607          return False;
1608       end Has_Pending_Instantiation;
1609
1610    --  Start of processing for Build_Body_To_Inline
1611
1612    begin
1613       if Nkind (Decl) = N_Subprogram_Declaration
1614         and then Present (Body_To_Inline (Decl))
1615       then
1616          return True;    --  Done already.
1617
1618       --  Functions that return unconstrained composite types will require
1619       --  secondary stack handling, and cannot currently be inlined.
1620
1621       elsif Ekind (Subp) = E_Function
1622         and then not Is_Scalar_Type (Etype (Subp))
1623         and then not Is_Access_Type (Etype (Subp))
1624         and then not Is_Constrained (Etype (Subp))
1625       then
1626          Cannot_Inline
1627            ("unconstrained return type prevents front-end inlining of&?", N);
1628          return False;
1629       end if;
1630
1631       --  We need to capture references to the formals in order to substitute
1632       --  the actuals at the point of inlining, i.e. instantiation. To treat
1633       --  the formals as globals to the body to inline, we nest it within
1634       --  a dummy parameterless subprogram, declared within the real one.
1635
1636       Original_Body := Orig_Body;
1637
1638       --  Within an instance, the current tree is already the result of
1639       --  a generic copy, and not what we need for subsequent inlining.
1640       --  We create the required body by doing an instantiating copy, to
1641       --  obtain the proper partially analyzed tree.
1642
1643       if In_Instance then
1644          if No (Generic_Parent (Specification (N))) then
1645             return False;
1646
1647          elsif Is_Child_Unit (Scope (Current_Scope)) then
1648             return False;
1649
1650          elsif Scope (Current_Scope) = Cunit_Entity (Main_Unit) then
1651
1652             --  compiling an instantiation. There is no point in generating
1653             --  bodies to inline, because they will not be used.
1654
1655             return False;
1656
1657          else
1658             Body_To_Analyze :=
1659               Copy_Generic_Node
1660                 (Generic_Parent (Specification (N)), Empty,
1661                    Instantiating => True);
1662          end if;
1663       else
1664          Body_To_Analyze :=
1665            Copy_Generic_Node (Original_Body, Empty,
1666              Instantiating => False);
1667       end if;
1668
1669       Set_Parameter_Specifications (Specification (Original_Body), No_List);
1670       Set_Defining_Unit_Name (Specification (Original_Body),
1671         Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
1672       Set_Corresponding_Spec (Original_Body, Empty);
1673
1674       if Ekind (Subp) = E_Function then
1675          Set_Subtype_Mark (Specification (Original_Body),
1676            New_Occurrence_Of (Etype (Subp), Sloc (N)));
1677       end if;
1678
1679       if Present (Declarations (Orig_Body))
1680         and then Has_Excluded_Declaration (Declarations (Orig_Body))
1681       then
1682          return False;
1683       end if;
1684
1685       if Present (Handled_Statement_Sequence (N)) then
1686          if
1687           (Present (Exception_Handlers (Handled_Statement_Sequence (N))))
1688          then
1689             Cannot_Inline ("handler prevents front-end inlining of&?",
1690                First (Exception_Handlers (Handled_Statement_Sequence (N))));
1691             return False;
1692          elsif
1693            Has_Excluded_Statement
1694              (Statements (Handled_Statement_Sequence (N)))
1695          then
1696             return False;
1697          end if;
1698       end if;
1699
1700       --  We do not inline a subprogram  that is too large, unless it is
1701       --  marked Inline_Always. This pragma does not suppress the other
1702       --  checks on inlining (forbidden declarations, handlers, etc).
1703
1704       if Stat_Count > Max_Size
1705         and then not Is_Always_Inlined (Subp)
1706       then
1707          Cannot_Inline ("body is too large for front-end inlining of&?", N);
1708          return False;
1709       end if;
1710
1711       if Has_Pending_Instantiation then
1712          Cannot_Inline
1713            ("cannot inline& because of forward instance within enclosing body",
1714              N);
1715          return False;
1716       end if;
1717
1718       Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
1719
1720       --  Set return type of function, which is also global and does not need
1721       --  to be resolved.
1722
1723       if Ekind (Subp) = E_Function then
1724          Set_Subtype_Mark (Specification (Body_To_Analyze),
1725            New_Occurrence_Of (Etype (Subp), Sloc (N)));
1726       end if;
1727
1728       if No (Declarations (N)) then
1729          Set_Declarations (N, New_List (Body_To_Analyze));
1730       else
1731          Append (Body_To_Analyze, Declarations (N));
1732       end if;
1733
1734       Expander_Mode_Save_And_Set (False);
1735
1736       Analyze (Body_To_Analyze);
1737       New_Scope (Defining_Entity (Body_To_Analyze));
1738       Save_Global_References (Original_Body);
1739       End_Scope;
1740       Remove (Body_To_Analyze);
1741
1742       Expander_Mode_Restore;
1743       Set_Body_To_Inline (Decl, Original_Body);
1744       Set_Is_Inlined (Subp);
1745       return True;
1746
1747    end Build_Body_To_Inline;
1748
1749    -----------------------
1750    -- Check_Conformance --
1751    -----------------------
1752
1753    procedure Check_Conformance
1754      (New_Id   : Entity_Id;
1755       Old_Id   : Entity_Id;
1756       Ctype    : Conformance_Type;
1757       Errmsg   : Boolean;
1758       Conforms : out Boolean;
1759       Err_Loc  : Node_Id := Empty;
1760       Get_Inst : Boolean := False)
1761    is
1762       Old_Type   : constant Entity_Id := Etype (Old_Id);
1763       New_Type   : constant Entity_Id := Etype (New_Id);
1764       Old_Formal : Entity_Id;
1765       New_Formal : Entity_Id;
1766
1767       procedure Conformance_Error (Msg : String; N : Node_Id := New_Id);
1768       --  Post error message for conformance error on given node.
1769       --  Two messages are output. The first points to the previous
1770       --  declaration with a general "no conformance" message.
1771       --  The second is the detailed reason, supplied as Msg. The
1772       --  parameter N provide information for a possible & insertion
1773       --  in the message, and also provides the location for posting
1774       --  the message in the absence of a specified Err_Loc location.
1775
1776       -----------------------
1777       -- Conformance_Error --
1778       -----------------------
1779
1780       procedure Conformance_Error (Msg : String; N : Node_Id := New_Id) is
1781          Enode : Node_Id;
1782
1783       begin
1784          Conforms := False;
1785
1786          if Errmsg then
1787             if No (Err_Loc) then
1788                Enode := N;
1789             else
1790                Enode := Err_Loc;
1791             end if;
1792
1793             Error_Msg_Sloc := Sloc (Old_Id);
1794
1795             case Ctype is
1796                when Type_Conformant =>
1797                   Error_Msg_N
1798                     ("not type conformant with declaration#!", Enode);
1799
1800                when Mode_Conformant =>
1801                   Error_Msg_N
1802                     ("not mode conformant with declaration#!", Enode);
1803
1804                when Subtype_Conformant =>
1805                   Error_Msg_N
1806                     ("not subtype conformant with declaration#!", Enode);
1807
1808                when Fully_Conformant =>
1809                   Error_Msg_N
1810                     ("not fully conformant with declaration#!", Enode);
1811             end case;
1812
1813             Error_Msg_NE (Msg, Enode, N);
1814          end if;
1815       end Conformance_Error;
1816
1817    --  Start of processing for Check_Conformance
1818
1819    begin
1820       Conforms := True;
1821
1822       --  We need a special case for operators, since they don't
1823       --  appear explicitly.
1824
1825       if Ctype = Type_Conformant then
1826          if Ekind (New_Id) = E_Operator
1827            and then Operator_Matches_Spec (New_Id, Old_Id)
1828          then
1829             return;
1830          end if;
1831       end if;
1832
1833       --  If both are functions/operators, check return types conform
1834
1835       if Old_Type /= Standard_Void_Type
1836         and then New_Type /= Standard_Void_Type
1837       then
1838          if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
1839             Conformance_Error ("return type does not match!", New_Id);
1840             return;
1841          end if;
1842
1843       --  If either is a function/operator and the other isn't, error
1844
1845       elsif Old_Type /= Standard_Void_Type
1846         or else New_Type /= Standard_Void_Type
1847       then
1848          Conformance_Error ("functions can only match functions!", New_Id);
1849          return;
1850       end if;
1851
1852       --  In subtype conformant case, conventions must match (RM 6.3.1(16))
1853       --  If this is a renaming as body, refine error message to indicate that
1854       --  the conflict is with the original declaration. If the entity is not
1855       --  frozen, the conventions don't have to match, the one of the renamed
1856       --  entity is inherited.
1857
1858       if Ctype >= Subtype_Conformant then
1859
1860          if Convention (Old_Id) /= Convention (New_Id) then
1861
1862             if not Is_Frozen (New_Id) then
1863                null;
1864
1865             elsif Present (Err_Loc)
1866               and then Nkind (Err_Loc) = N_Subprogram_Renaming_Declaration
1867               and then Present (Corresponding_Spec (Err_Loc))
1868             then
1869                Error_Msg_Name_1 := Chars (New_Id);
1870                Error_Msg_Name_2 :=
1871                  Name_Ada + Convention_Id'Pos (Convention (New_Id));
1872
1873                Conformance_Error ("prior declaration for% has convention %!");
1874
1875             else
1876                Conformance_Error ("calling conventions do not match!");
1877             end if;
1878
1879             return;
1880
1881          elsif Is_Formal_Subprogram (Old_Id)
1882            or else Is_Formal_Subprogram (New_Id)
1883          then
1884             Conformance_Error ("formal subprograms not allowed!");
1885             return;
1886          end if;
1887       end if;
1888
1889       --  Deal with parameters
1890
1891       --  Note: we use the entity information, rather than going directly
1892       --  to the specification in the tree. This is not only simpler, but
1893       --  absolutely necessary for some cases of conformance tests between
1894       --  operators, where the declaration tree simply does not exist!
1895
1896       Old_Formal := First_Formal (Old_Id);
1897       New_Formal := First_Formal (New_Id);
1898
1899       while Present (Old_Formal) and then Present (New_Formal) loop
1900
1901          --  Types must always match. In the visible part of an instance,
1902          --  usual overloading rules for dispatching operations apply, and
1903          --  we check base types (not the actual subtypes).
1904
1905          if In_Instance_Visible_Part
1906            and then Is_Dispatching_Operation (New_Id)
1907          then
1908             if not Conforming_Types
1909               (Base_Type (Etype (Old_Formal)),
1910                  Base_Type (Etype (New_Formal)), Ctype, Get_Inst)
1911             then
1912                Conformance_Error ("type of & does not match!", New_Formal);
1913                return;
1914             end if;
1915
1916          elsif not Conforming_Types
1917            (Etype (Old_Formal), Etype (New_Formal), Ctype, Get_Inst)
1918          then
1919             Conformance_Error ("type of & does not match!", New_Formal);
1920             return;
1921          end if;
1922
1923          --  For mode conformance, mode must match
1924
1925          if Ctype >= Mode_Conformant
1926            and then Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal)
1927          then
1928             Conformance_Error ("mode of & does not match!", New_Formal);
1929             return;
1930          end if;
1931
1932          --  Full conformance checks
1933
1934          if Ctype = Fully_Conformant then
1935
1936             --  Names must match
1937
1938             if Chars (Old_Formal) /= Chars (New_Formal) then
1939                Conformance_Error ("name & does not match!", New_Formal);
1940                return;
1941
1942             --  And default expressions for in parameters
1943
1944             elsif Parameter_Mode (Old_Formal) = E_In_Parameter then
1945                declare
1946                   NewD : constant Boolean :=
1947                            Present (Default_Value (New_Formal));
1948                   OldD : constant Boolean :=
1949                            Present (Default_Value (Old_Formal));
1950                begin
1951                   if NewD or OldD then
1952
1953                      --  The old default value has been analyzed and expanded,
1954                      --  because the current full declaration will have frozen
1955                      --  everything before. The new default values have not
1956                      --  been expanded, so expand now to check conformance.
1957
1958                      if NewD then
1959                         New_Scope (New_Id);
1960                         Analyze_Default_Expression
1961                          (Default_Value (New_Formal), Etype (New_Formal));
1962                         End_Scope;
1963                      end if;
1964
1965                      if not (NewD and OldD)
1966                        or else not Fully_Conformant_Expressions
1967                                     (Default_Value (Old_Formal),
1968                                      Default_Value (New_Formal))
1969                      then
1970                         Conformance_Error
1971                           ("default expression for & does not match!",
1972                            New_Formal);
1973                         return;
1974                      end if;
1975                   end if;
1976                end;
1977             end if;
1978          end if;
1979
1980          --  A couple of special checks for Ada 83 mode. These checks are
1981          --  skipped if either entity is an operator in package Standard.
1982          --  or if either old or new instance is not from the source program.
1983
1984          if Ada_83
1985            and then Sloc (Old_Id) > Standard_Location
1986            and then Sloc (New_Id) > Standard_Location
1987            and then Comes_From_Source (Old_Id)
1988            and then Comes_From_Source (New_Id)
1989          then
1990             declare
1991                Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
1992                New_Param : constant Node_Id := Declaration_Node (New_Formal);
1993
1994             begin
1995                --  Explicit IN must be present or absent in both cases. This
1996                --  test is required only in the full conformance case.
1997
1998                if In_Present (Old_Param) /= In_Present (New_Param)
1999                  and then Ctype = Fully_Conformant
2000                then
2001                   Conformance_Error
2002                     ("(Ada 83) IN must appear in both declarations",
2003                      New_Formal);
2004                   return;
2005                end if;
2006
2007                --  Grouping (use of comma in param lists) must be the same
2008                --  This is where we catch a misconformance like:
2009
2010                --    A,B : Integer
2011                --    A : Integer; B : Integer
2012
2013                --  which are represented identically in the tree except
2014                --  for the setting of the flags More_Ids and Prev_Ids.
2015
2016                if More_Ids (Old_Param) /= More_Ids (New_Param)
2017                  or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
2018                then
2019                   Conformance_Error
2020                     ("grouping of & does not match!", New_Formal);
2021                   return;
2022                end if;
2023             end;
2024          end if;
2025
2026          Next_Formal (Old_Formal);
2027          Next_Formal (New_Formal);
2028       end loop;
2029
2030       if Present (Old_Formal) then
2031          Conformance_Error ("too few parameters!");
2032          return;
2033
2034       elsif Present (New_Formal) then
2035          Conformance_Error ("too many parameters!", New_Formal);
2036          return;
2037       end if;
2038
2039    end Check_Conformance;
2040
2041    ------------------------------
2042    -- Check_Delayed_Subprogram --
2043    ------------------------------
2044
2045    procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
2046       F : Entity_Id;
2047
2048       procedure Possible_Freeze (T : Entity_Id);
2049       --  T is the type of either a formal parameter or of the return type.
2050       --  If T is not yet frozen and needs a delayed freeze, then the
2051       --  subprogram itself must be delayed.
2052
2053       procedure Possible_Freeze (T : Entity_Id) is
2054       begin
2055          if Has_Delayed_Freeze (T)
2056            and then not Is_Frozen (T)
2057          then
2058             Set_Has_Delayed_Freeze (Designator);
2059
2060          elsif Is_Access_Type (T)
2061            and then Has_Delayed_Freeze (Designated_Type (T))
2062            and then not Is_Frozen (Designated_Type (T))
2063          then
2064             Set_Has_Delayed_Freeze (Designator);
2065          end if;
2066       end Possible_Freeze;
2067
2068    --  Start of processing for Check_Delayed_Subprogram
2069
2070    begin
2071       --  Never need to freeze abstract subprogram
2072
2073       if Is_Abstract (Designator) then
2074          null;
2075       else
2076          --  Need delayed freeze if return type itself needs a delayed
2077          --  freeze and is not yet frozen.
2078
2079          Possible_Freeze (Etype (Designator));
2080          Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
2081
2082          --  Need delayed freeze if any of the formal types themselves need
2083          --  a delayed freeze and are not yet frozen.
2084
2085          F := First_Formal (Designator);
2086          while Present (F) loop
2087             Possible_Freeze (Etype (F));
2088             Possible_Freeze (Base_Type (Etype (F))); -- needed ???
2089             Next_Formal (F);
2090          end loop;
2091       end if;
2092
2093       --  Mark functions that return by reference. Note that it cannot be
2094       --  done for delayed_freeze subprograms because the underlying
2095       --  returned type may not be known yet (for private types)
2096
2097       if not Has_Delayed_Freeze (Designator)
2098         and then Expander_Active
2099       then
2100          declare
2101             Typ  : constant Entity_Id := Etype (Designator);
2102             Utyp : constant Entity_Id := Underlying_Type (Typ);
2103
2104          begin
2105             if Is_Return_By_Reference_Type (Typ) then
2106                Set_Returns_By_Ref (Designator);
2107
2108             elsif Present (Utyp) and then Controlled_Type (Utyp) then
2109                Set_Returns_By_Ref (Designator);
2110             end if;
2111          end;
2112       end if;
2113    end Check_Delayed_Subprogram;
2114
2115    ------------------------------------
2116    -- Check_Discriminant_Conformance --
2117    ------------------------------------
2118
2119    procedure Check_Discriminant_Conformance
2120      (N        : Node_Id;
2121       Prev     : Entity_Id;
2122       Prev_Loc : Node_Id)
2123    is
2124       Old_Discr      : Entity_Id := First_Discriminant (Prev);
2125       New_Discr      : Node_Id   := First (Discriminant_Specifications (N));
2126       New_Discr_Id   : Entity_Id;
2127       New_Discr_Type : Entity_Id;
2128
2129       procedure Conformance_Error (Msg : String; N : Node_Id);
2130       --  Post error message for conformance error on given node.
2131       --  Two messages are output. The first points to the previous
2132       --  declaration with a general "no conformance" message.
2133       --  The second is the detailed reason, supplied as Msg. The
2134       --  parameter N provide information for a possible & insertion
2135       --  in the message.
2136
2137       -----------------------
2138       -- Conformance_Error --
2139       -----------------------
2140
2141       procedure Conformance_Error (Msg : String; N : Node_Id) is
2142       begin
2143          Error_Msg_Sloc := Sloc (Prev_Loc);
2144          Error_Msg_N ("not fully conformant with declaration#!", N);
2145          Error_Msg_NE (Msg, N, N);
2146       end Conformance_Error;
2147
2148    --  Start of processing for Check_Discriminant_Conformance
2149
2150    begin
2151       while Present (Old_Discr) and then Present (New_Discr) loop
2152
2153          New_Discr_Id := Defining_Identifier (New_Discr);
2154
2155          --  The subtype mark of the discriminant on the full type
2156          --  has not been analyzed so we do it here. For an access
2157          --  discriminant a new type is created.
2158
2159          if Nkind (Discriminant_Type (New_Discr)) = N_Access_Definition then
2160             New_Discr_Type :=
2161               Access_Definition (N, Discriminant_Type (New_Discr));
2162
2163          else
2164             Analyze (Discriminant_Type (New_Discr));
2165             New_Discr_Type := Etype (Discriminant_Type (New_Discr));
2166          end if;
2167
2168          if not Conforming_Types
2169                   (Etype (Old_Discr), New_Discr_Type, Fully_Conformant)
2170          then
2171             Conformance_Error ("type of & does not match!", New_Discr_Id);
2172             return;
2173          end if;
2174
2175          --  Names must match
2176
2177          if Chars (Old_Discr) /= Chars (Defining_Identifier (New_Discr)) then
2178             Conformance_Error ("name & does not match!", New_Discr_Id);
2179             return;
2180          end if;
2181
2182          --  Default expressions must match
2183
2184          declare
2185             NewD : constant Boolean :=
2186                      Present (Expression (New_Discr));
2187             OldD : constant Boolean :=
2188                      Present (Expression (Parent (Old_Discr)));
2189
2190          begin
2191             if NewD or OldD then
2192
2193                --  The old default value has been analyzed and expanded,
2194                --  because the current full declaration will have frozen
2195                --  everything before. The new default values have not
2196                --  been expanded, so expand now to check conformance.
2197
2198                if NewD then
2199                   Analyze_Default_Expression
2200                     (Expression (New_Discr), New_Discr_Type);
2201                end if;
2202
2203                if not (NewD and OldD)
2204                  or else not Fully_Conformant_Expressions
2205                               (Expression (Parent (Old_Discr)),
2206                                Expression (New_Discr))
2207
2208                then
2209                   Conformance_Error
2210                     ("default expression for & does not match!",
2211                      New_Discr_Id);
2212                   return;
2213                end if;
2214             end if;
2215          end;
2216
2217          --  In Ada 83 case, grouping must match: (A,B : X) /= (A : X; B : X)
2218
2219          if Ada_83 then
2220             declare
2221                Old_Disc : constant Node_Id := Declaration_Node (Old_Discr);
2222
2223             begin
2224                --  Grouping (use of comma in param lists) must be the same
2225                --  This is where we catch a misconformance like:
2226
2227                --    A,B : Integer
2228                --    A : Integer; B : Integer
2229
2230                --  which are represented identically in the tree except
2231                --  for the setting of the flags More_Ids and Prev_Ids.
2232
2233                if More_Ids (Old_Disc) /= More_Ids (New_Discr)
2234                  or else Prev_Ids (Old_Disc) /= Prev_Ids (New_Discr)
2235                then
2236                   Conformance_Error
2237                     ("grouping of & does not match!", New_Discr_Id);
2238                   return;
2239                end if;
2240             end;
2241          end if;
2242
2243          Next_Discriminant (Old_Discr);
2244          Next (New_Discr);
2245       end loop;
2246
2247       if Present (Old_Discr) then
2248          Conformance_Error ("too few discriminants!", Defining_Identifier (N));
2249          return;
2250
2251       elsif Present (New_Discr) then
2252          Conformance_Error
2253            ("too many discriminants!", Defining_Identifier (New_Discr));
2254          return;
2255       end if;
2256    end Check_Discriminant_Conformance;
2257
2258    ----------------------------
2259    -- Check_Fully_Conformant --
2260    ----------------------------
2261
2262    procedure Check_Fully_Conformant
2263      (New_Id  : Entity_Id;
2264       Old_Id  : Entity_Id;
2265       Err_Loc : Node_Id := Empty)
2266    is
2267       Result : Boolean;
2268
2269    begin
2270       Check_Conformance
2271         (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
2272    end Check_Fully_Conformant;
2273
2274    ---------------------------
2275    -- Check_Mode_Conformant --
2276    ---------------------------
2277
2278    procedure Check_Mode_Conformant
2279      (New_Id   : Entity_Id;
2280       Old_Id   : Entity_Id;
2281       Err_Loc  : Node_Id := Empty;
2282       Get_Inst : Boolean := False)
2283    is
2284       Result : Boolean;
2285
2286    begin
2287       Check_Conformance
2288         (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
2289    end Check_Mode_Conformant;
2290
2291    -------------------
2292    -- Check_Returns --
2293    -------------------
2294
2295    procedure Check_Returns
2296      (HSS  : Node_Id;
2297       Mode : Character;
2298       Err  : out Boolean)
2299    is
2300       Handler : Node_Id;
2301
2302       procedure Check_Statement_Sequence (L : List_Id);
2303       --  Internal recursive procedure to check a list of statements for proper
2304       --  termination by a return statement (or a transfer of control or a
2305       --  compound statement that is itself internally properly terminated).
2306
2307       ------------------------------
2308       -- Check_Statement_Sequence --
2309       ------------------------------
2310
2311       procedure Check_Statement_Sequence (L : List_Id) is
2312          Last_Stm : Node_Id;
2313          Kind     : Node_Kind;
2314
2315          Raise_Exception_Call : Boolean;
2316          --  Set True if statement sequence terminated by Raise_Exception call
2317          --  or a Reraise_Occurrence call.
2318
2319       begin
2320          Raise_Exception_Call := False;
2321
2322          --  Get last real statement
2323
2324          Last_Stm := Last (L);
2325
2326          --  Don't count pragmas
2327
2328          while Nkind (Last_Stm) = N_Pragma
2329
2330          --  Don't count call to SS_Release (can happen after Raise_Exception)
2331
2332            or else
2333              (Nkind (Last_Stm) = N_Procedure_Call_Statement
2334                 and then
2335               Nkind (Name (Last_Stm)) = N_Identifier
2336                 and then
2337               Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
2338
2339          --  Don't count exception junk
2340
2341            or else
2342              ((Nkind (Last_Stm) = N_Goto_Statement
2343                  or else Nkind (Last_Stm) = N_Label
2344                  or else Nkind (Last_Stm) = N_Object_Declaration)
2345                and then Exception_Junk (Last_Stm))
2346          loop
2347             Prev (Last_Stm);
2348          end loop;
2349
2350          --  Here we have the "real" last statement
2351
2352          Kind := Nkind (Last_Stm);
2353
2354          --  Transfer of control, OK. Note that in the No_Return procedure
2355          --  case, we already diagnosed any explicit return statements, so
2356          --  we can treat them as OK in this context.
2357
2358          if Is_Transfer (Last_Stm) then
2359             return;
2360
2361          --  Check cases of explicit non-indirect procedure calls
2362
2363          elsif Kind = N_Procedure_Call_Statement
2364            and then Is_Entity_Name (Name (Last_Stm))
2365          then
2366             --  Check call to Raise_Exception procedure which is treated
2367             --  specially, as is a call to Reraise_Occurrence.
2368
2369             --  We suppress the warning in these cases since it is likely that
2370             --  the programmer really does not expect to deal with the case
2371             --  of Null_Occurrence, and thus would find a warning about a
2372             --  missing return curious, and raising Program_Error does not
2373             --  seem such a bad behavior if this does occur.
2374
2375             if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
2376                  or else
2377                Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
2378             then
2379                Raise_Exception_Call := True;
2380
2381                --  For Raise_Exception call, test first argument, if it is
2382                --  an attribute reference for a 'Identity call, then we know
2383                --  that the call cannot possibly return.
2384
2385                declare
2386                   Arg : constant Node_Id :=
2387                           Original_Node (First_Actual (Last_Stm));
2388
2389                begin
2390                   if Nkind (Arg) = N_Attribute_Reference
2391                     and then Attribute_Name (Arg) = Name_Identity
2392                   then
2393                      return;
2394                   end if;
2395                end;
2396             end if;
2397
2398          --  If statement, need to look inside if there is an else and check
2399          --  each constituent statement sequence for proper termination.
2400
2401          elsif Kind = N_If_Statement
2402            and then Present (Else_Statements (Last_Stm))
2403          then
2404             Check_Statement_Sequence (Then_Statements (Last_Stm));
2405             Check_Statement_Sequence (Else_Statements (Last_Stm));
2406
2407             if Present (Elsif_Parts (Last_Stm)) then
2408                declare
2409                   Elsif_Part : Node_Id := First (Elsif_Parts (Last_Stm));
2410
2411                begin
2412                   while Present (Elsif_Part) loop
2413                      Check_Statement_Sequence (Then_Statements (Elsif_Part));
2414                      Next (Elsif_Part);
2415                   end loop;
2416                end;
2417             end if;
2418
2419             return;
2420
2421          --  Case statement, check each case for proper termination
2422
2423          elsif Kind = N_Case_Statement then
2424             declare
2425                Case_Alt : Node_Id;
2426
2427             begin
2428                Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
2429                while Present (Case_Alt) loop
2430                   Check_Statement_Sequence (Statements (Case_Alt));
2431                   Next_Non_Pragma (Case_Alt);
2432                end loop;
2433             end;
2434
2435             return;
2436
2437          --  Block statement, check its handled sequence of statements
2438
2439          elsif Kind = N_Block_Statement then
2440             declare
2441                Err1 : Boolean;
2442
2443             begin
2444                Check_Returns
2445                  (Handled_Statement_Sequence (Last_Stm), Mode, Err1);
2446
2447                if Err1 then
2448                   Err := True;
2449                end if;
2450
2451                return;
2452             end;
2453
2454          --  Loop statement. If there is an iteration scheme, we can definitely
2455          --  fall out of the loop. Similarly if there is an exit statement, we
2456          --  can fall out. In either case we need a following return.
2457
2458          elsif Kind = N_Loop_Statement then
2459             if Present (Iteration_Scheme (Last_Stm))
2460               or else Has_Exit (Entity (Identifier (Last_Stm)))
2461             then
2462                null;
2463
2464             --  A loop with no exit statement or iteration scheme if either
2465             --  an inifite loop, or it has some other exit (raise/return).
2466             --  In either case, no warning is required.
2467
2468             else
2469                return;
2470             end if;
2471
2472          --  Timed entry call, check entry call and delay alternatives
2473
2474          --  Note: in expanded code, the timed entry call has been converted
2475          --  to a set of expanded statements on which the check will work
2476          --  correctly in any case.
2477
2478          elsif Kind = N_Timed_Entry_Call then
2479             declare
2480                ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
2481                DCA : constant Node_Id := Delay_Alternative      (Last_Stm);
2482
2483             begin
2484                --  If statement sequence of entry call alternative is missing,
2485                --  then we can definitely fall through, and we post the error
2486                --  message on the entry call alternative itself.
2487
2488                if No (Statements (ECA)) then
2489                   Last_Stm := ECA;
2490
2491                --  If statement sequence of delay alternative is missing, then
2492                --  we can definitely fall through, and we post the error
2493                --  message on the delay alternative itself.
2494
2495                --  Note: if both ECA and DCA are missing the return, then we
2496                --  post only one message, should be enough to fix the bugs.
2497                --  If not we will get a message next time on the DCA when the
2498                --  ECA is fixed!
2499
2500                elsif No (Statements (DCA)) then
2501                   Last_Stm := DCA;
2502
2503                --  Else check both statement sequences
2504
2505                else
2506                   Check_Statement_Sequence (Statements (ECA));
2507                   Check_Statement_Sequence (Statements (DCA));
2508                   return;
2509                end if;
2510             end;
2511
2512          --  Conditional entry call, check entry call and else part
2513
2514          --  Note: in expanded code, the conditional entry call has been
2515          --  converted to a set of expanded statements on which the check
2516          --  will work correctly in any case.
2517
2518          elsif Kind = N_Conditional_Entry_Call then
2519             declare
2520                ECA : constant Node_Id := Entry_Call_Alternative (Last_Stm);
2521
2522             begin
2523                --  If statement sequence of entry call alternative is missing,
2524                --  then we can definitely fall through, and we post the error
2525                --  message on the entry call alternative itself.
2526
2527                if No (Statements (ECA)) then
2528                   Last_Stm := ECA;
2529
2530                --  Else check statement sequence and else part
2531
2532                else
2533                   Check_Statement_Sequence (Statements (ECA));
2534                   Check_Statement_Sequence (Else_Statements (Last_Stm));
2535                   return;
2536                end if;
2537             end;
2538          end if;
2539
2540          --  If we fall through, issue appropriate message
2541
2542          if Mode = 'F' then
2543
2544             if not Raise_Exception_Call then
2545                Error_Msg_N
2546                  ("?RETURN statement missing following this statement!",
2547                   Last_Stm);
2548                Error_Msg_N
2549                  ("\?Program_Error may be raised at run time",
2550                   Last_Stm);
2551             end if;
2552
2553             --  Note: we set Err even though we have not issued a warning
2554             --  because we still have a case of a missing return. This is
2555             --  an extremely marginal case, probably will never be noticed
2556             --  but we might as well get it right.
2557
2558             Err := True;
2559
2560          else
2561             Error_Msg_N
2562               ("implied return after this statement not allowed (No_Return)",
2563                Last_Stm);
2564          end if;
2565       end Check_Statement_Sequence;
2566
2567    --  Start of processing for Check_Returns
2568
2569    begin
2570       Err := False;
2571       Check_Statement_Sequence (Statements (HSS));
2572
2573       if Present (Exception_Handlers (HSS)) then
2574          Handler := First_Non_Pragma (Exception_Handlers (HSS));
2575          while Present (Handler) loop
2576             Check_Statement_Sequence (Statements (Handler));
2577             Next_Non_Pragma (Handler);
2578          end loop;
2579       end if;
2580    end Check_Returns;
2581
2582    ----------------------------
2583    -- Check_Subprogram_Order --
2584    ----------------------------
2585
2586    procedure Check_Subprogram_Order (N : Node_Id) is
2587
2588       function Subprogram_Name_Greater (S1, S2 : String) return Boolean;
2589       --  This is used to check if S1 > S2 in the sense required by this
2590       --  test, for example nameab < namec, but name2 < name10.
2591
2592       function Subprogram_Name_Greater (S1, S2 : String) return Boolean is
2593          L1, L2 : Positive;
2594          N1, N2 : Natural;
2595
2596       begin
2597          --  Remove trailing numeric parts
2598
2599          L1 := S1'Last;
2600          while S1 (L1) in '0' .. '9' loop
2601             L1 := L1 - 1;
2602          end loop;
2603
2604          L2 := S2'Last;
2605          while S2 (L2) in '0' .. '9' loop
2606             L2 := L2 - 1;
2607          end loop;
2608
2609          --  If non-numeric parts non-equal, that's decisive
2610
2611          if S1 (S1'First .. L1) < S2 (S2'First .. L2) then
2612             return False;
2613
2614          elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then
2615             return True;
2616
2617          --  If non-numeric parts equal, compare suffixed numeric parts. Note
2618          --  that a missing suffix is treated as numeric zero in this test.
2619
2620          else
2621             N1 := 0;
2622             while L1 < S1'Last loop
2623                L1 := L1 + 1;
2624                N1 := N1 * 10 + Character'Pos (S1 (L1)) - Character'Pos ('0');
2625             end loop;
2626
2627             N2 := 0;
2628             while L2 < S2'Last loop
2629                L2 := L2 + 1;
2630                N2 := N2 * 10 + Character'Pos (S2 (L2)) - Character'Pos ('0');
2631             end loop;
2632
2633             return N1 > N2;
2634          end if;
2635       end Subprogram_Name_Greater;
2636
2637    --  Start of processing for Check_Subprogram_Order
2638
2639    begin
2640       --  Check body in alpha order if this is option
2641
2642       if Style_Check_Subprogram_Order
2643         and then Nkind (N) = N_Subprogram_Body
2644         and then Comes_From_Source (N)
2645         and then In_Extended_Main_Source_Unit (N)
2646       then
2647          declare
2648             LSN : String_Ptr
2649                     renames Scope_Stack.Table
2650                               (Scope_Stack.Last).Last_Subprogram_Name;
2651
2652             Body_Id : constant Entity_Id :=
2653                         Defining_Entity (Specification (N));
2654
2655          begin
2656             Get_Decoded_Name_String (Chars (Body_Id));
2657
2658             if LSN /= null then
2659                if Subprogram_Name_Greater
2660                     (LSN.all, Name_Buffer (1 .. Name_Len))
2661                then
2662                   Style.Subprogram_Not_In_Alpha_Order (Body_Id);
2663                end if;
2664
2665                Free (LSN);
2666             end if;
2667
2668             LSN := new String'(Name_Buffer (1 .. Name_Len));
2669          end;
2670       end if;
2671    end Check_Subprogram_Order;
2672
2673    ------------------------------
2674    -- Check_Subtype_Conformant --
2675    ------------------------------
2676
2677    procedure Check_Subtype_Conformant
2678      (New_Id  : Entity_Id;
2679       Old_Id  : Entity_Id;
2680       Err_Loc : Node_Id := Empty)
2681    is
2682       Result : Boolean;
2683
2684    begin
2685       Check_Conformance
2686         (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
2687    end Check_Subtype_Conformant;
2688
2689    ---------------------------
2690    -- Check_Type_Conformant --
2691    ---------------------------
2692
2693    procedure Check_Type_Conformant
2694      (New_Id  : Entity_Id;
2695       Old_Id  : Entity_Id;
2696       Err_Loc : Node_Id := Empty)
2697    is
2698       Result : Boolean;
2699
2700    begin
2701       Check_Conformance
2702         (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
2703    end Check_Type_Conformant;
2704
2705    ----------------------
2706    -- Conforming_Types --
2707    ----------------------
2708
2709    function Conforming_Types
2710      (T1       : Entity_Id;
2711       T2       : Entity_Id;
2712       Ctype    : Conformance_Type;
2713       Get_Inst : Boolean := False)
2714       return     Boolean
2715    is
2716       Type_1 : Entity_Id := T1;
2717       Type_2 : Entity_Id := T2;
2718
2719       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
2720       --  If neither T1 nor T2 are generic actual types, or if they are
2721       --  in different scopes (e.g. parent and child instances), then verify
2722       --  that the base types are equal. Otherwise T1 and T2 must be
2723       --  on the same subtype chain. The whole purpose of this procedure
2724       --  is to prevent spurious ambiguities in an instantiation that may
2725       --  arise if two distinct generic types are instantiated with the
2726       --  same actual.
2727
2728       ----------------------
2729       -- Base_Types_Match --
2730       ----------------------
2731
2732       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
2733       begin
2734          if T1 = T2 then
2735             return True;
2736
2737          elsif Base_Type (T1) = Base_Type (T2) then
2738
2739             --  The following is too permissive. A more precise test must
2740             --  check that the generic actual is an ancestor subtype of the
2741             --  other ???.
2742
2743             return not Is_Generic_Actual_Type (T1)
2744               or else not Is_Generic_Actual_Type (T2)
2745               or else Scope (T1) /= Scope (T2);
2746
2747          else
2748             return False;
2749          end if;
2750       end Base_Types_Match;
2751
2752    begin
2753       --  The context is an instance association for a formal
2754       --  access-to-subprogram type; the formal parameter types
2755       --  require mapping because they may denote other formal
2756       --  parameters of the generic unit.
2757
2758       if Get_Inst then
2759          Type_1 := Get_Instance_Of (T1);
2760          Type_2 := Get_Instance_Of (T2);
2761       end if;
2762
2763       --  First see if base types match
2764
2765       if Base_Types_Match (Type_1, Type_2) then
2766          return Ctype <= Mode_Conformant
2767            or else Subtypes_Statically_Match (Type_1, Type_2);
2768
2769       elsif Is_Incomplete_Or_Private_Type (Type_1)
2770         and then Present (Full_View (Type_1))
2771         and then Base_Types_Match (Full_View (Type_1), Type_2)
2772       then
2773          return Ctype <= Mode_Conformant
2774            or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
2775
2776       elsif Ekind (Type_2) = E_Incomplete_Type
2777         and then Present (Full_View (Type_2))
2778         and then Base_Types_Match (Type_1, Full_View (Type_2))
2779       then
2780          return Ctype <= Mode_Conformant
2781            or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
2782       end if;
2783
2784       --  Test anonymous access type case. For this case, static subtype
2785       --  matching is required for mode conformance (RM 6.3.1(15))
2786
2787       if Ekind (Type_1) = E_Anonymous_Access_Type
2788         and then Ekind (Type_2) = E_Anonymous_Access_Type
2789       then
2790          declare
2791             Desig_1 : Entity_Id;
2792             Desig_2 : Entity_Id;
2793
2794          begin
2795             Desig_1 := Directly_Designated_Type (Type_1);
2796
2797             --  An access parameter can designate an incomplete type.
2798
2799             if Ekind (Desig_1) = E_Incomplete_Type
2800               and then Present (Full_View (Desig_1))
2801             then
2802                Desig_1 := Full_View (Desig_1);
2803             end if;
2804
2805             Desig_2 := Directly_Designated_Type (Type_2);
2806
2807             if Ekind (Desig_2) = E_Incomplete_Type
2808               and then Present (Full_View (Desig_2))
2809             then
2810                Desig_2 := Full_View (Desig_2);
2811             end if;
2812
2813             --  The context is an instance association for a formal
2814             --  access-to-subprogram type; formal access parameter
2815             --  designated types require mapping because they may
2816             --  denote other formal parameters of the generic unit.
2817
2818             if Get_Inst then
2819                Desig_1 := Get_Instance_Of (Desig_1);
2820                Desig_2 := Get_Instance_Of (Desig_2);
2821             end if;
2822
2823             --  It is possible for a Class_Wide_Type to be introduced for
2824             --  an incomplete type, in which case there is a separate class_
2825             --  wide type for the full view. The types conform if their
2826             --  Etypes conform, i.e. one may be the full view of the other.
2827             --  This can only happen in the context of an access parameter,
2828             --  other uses of an incomplete Class_Wide_Type are illegal.
2829
2830             if Ekind (Desig_1) = E_Class_Wide_Type
2831               and then Ekind (Desig_2) = E_Class_Wide_Type
2832             then
2833                return
2834                  Conforming_Types (Etype (Desig_1), Etype (Desig_2), Ctype);
2835             else
2836                return Base_Type (Desig_1) = Base_Type (Desig_2)
2837                 and then (Ctype = Type_Conformant
2838                           or else
2839                         Subtypes_Statically_Match (Desig_1, Desig_2));
2840             end if;
2841          end;
2842
2843       --  Otherwise definitely no match
2844
2845       else
2846          return False;
2847       end if;
2848
2849    end Conforming_Types;
2850
2851    --------------------------
2852    -- Create_Extra_Formals --
2853    --------------------------
2854
2855    procedure Create_Extra_Formals (E : Entity_Id) is
2856       Formal      : Entity_Id;
2857       Last_Formal : Entity_Id;
2858       Last_Extra  : Entity_Id;
2859       Formal_Type : Entity_Id;
2860       P_Formal    : Entity_Id := Empty;
2861
2862       function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id;
2863       --  Add an extra formal, associated with the current Formal. The
2864       --  extra formal is added to the list of extra formals, and also
2865       --  returned as the result. These formals are always of mode IN.
2866
2867       function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id is
2868          EF : constant Entity_Id :=
2869                 Make_Defining_Identifier (Sloc (Formal),
2870                   Chars => New_External_Name (Chars (Formal), 'F'));
2871
2872       begin
2873          --  We never generate extra formals if expansion is not active
2874          --  because we don't need them unless we are generating code.
2875
2876          if not Expander_Active then
2877             return Empty;
2878          end if;
2879
2880          --  A little optimization. Never generate an extra formal for
2881          --  the _init operand of an initialization procedure, since it
2882          --  could never be used.
2883
2884          if Chars (Formal) = Name_uInit then
2885             return Empty;
2886          end if;
2887
2888          Set_Ekind           (EF, E_In_Parameter);
2889          Set_Actual_Subtype  (EF, Typ);
2890          Set_Etype           (EF, Typ);
2891          Set_Scope           (EF, Scope (Formal));
2892          Set_Mechanism       (EF, Default_Mechanism);
2893          Set_Formal_Validity (EF);
2894
2895          Set_Extra_Formal (Last_Extra, EF);
2896          Last_Extra := EF;
2897          return EF;
2898       end Add_Extra_Formal;
2899
2900    --  Start of processing for Create_Extra_Formals
2901
2902    begin
2903       --  If this is a derived subprogram then the subtypes of the
2904       --  parent subprogram's formal parameters will be used to
2905       --  to determine the need for extra formals.
2906
2907       if Is_Overloadable (E) and then Present (Alias (E)) then
2908          P_Formal := First_Formal (Alias (E));
2909       end if;
2910
2911       Last_Extra := Empty;
2912       Formal := First_Formal (E);
2913       while Present (Formal) loop
2914          Last_Extra := Formal;
2915          Next_Formal (Formal);
2916       end loop;
2917
2918       --  If Extra_formals where already created, don't do it again
2919       --  This situation may arise for subprogram types created as part
2920       --  of dispatching calls (see Expand_Dispatch_Call)
2921
2922       if Present (Last_Extra) and then
2923         Present (Extra_Formal (Last_Extra))
2924       then
2925          return;
2926       end if;
2927
2928       Formal := First_Formal (E);
2929
2930       while Present (Formal) loop
2931
2932          --  Create extra formal for supporting the attribute 'Constrained.
2933          --  The case of a private type view without discriminants also
2934          --  requires the extra formal if the underlying type has defaulted
2935          --  discriminants.
2936
2937          if Ekind (Formal) /= E_In_Parameter then
2938             if Present (P_Formal) then
2939                Formal_Type := Etype (P_Formal);
2940             else
2941                Formal_Type := Etype (Formal);
2942             end if;
2943
2944             if not Has_Discriminants (Formal_Type)
2945               and then Ekind (Formal_Type) in Private_Kind
2946               and then Present (Underlying_Type (Formal_Type))
2947             then
2948                Formal_Type := Underlying_Type (Formal_Type);
2949             end if;
2950
2951             if Has_Discriminants (Formal_Type)
2952               and then
2953                 ((not Is_Constrained (Formal_Type)
2954                     and then not Is_Indefinite_Subtype (Formal_Type))
2955                   or else Present (Extra_Formal (Formal)))
2956             then
2957                Set_Extra_Constrained
2958                  (Formal, Add_Extra_Formal (Standard_Boolean));
2959             end if;
2960          end if;
2961
2962          --  Create extra formal for supporting accessibility checking
2963
2964          --  This is suppressed if we specifically suppress accessibility
2965          --  checks for either the subprogram, or the package in which it
2966          --  resides. However, we do not suppress it simply if the scope
2967          --  has accessibility checks suppressed, since this could cause
2968          --  trouble when clients are compiled with a different suppression
2969          --  setting. The explicit checks are safe from this point of view.
2970
2971          if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
2972            and then not
2973              (Suppress_Accessibility_Checks (E)
2974                or else
2975               Suppress_Accessibility_Checks (Scope (E)))
2976            and then
2977              (not Present (P_Formal)
2978                or else Present (Extra_Accessibility (P_Formal)))
2979          then
2980             --  Temporary kludge: for now we avoid creating the extra
2981             --  formal for access parameters of protected operations
2982             --  because of problem with the case of internal protected
2983             --  calls. ???
2984
2985             if Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Definition
2986               and then Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Body
2987             then
2988                Set_Extra_Accessibility
2989                  (Formal, Add_Extra_Formal (Standard_Natural));
2990             end if;
2991          end if;
2992
2993          if Present (P_Formal) then
2994             Next_Formal (P_Formal);
2995          end if;
2996
2997          Last_Formal := Formal;
2998          Next_Formal (Formal);
2999       end loop;
3000    end Create_Extra_Formals;
3001
3002    -----------------------------
3003    -- Enter_Overloaded_Entity --
3004    -----------------------------
3005
3006    procedure Enter_Overloaded_Entity (S : Entity_Id) is
3007       E   : Entity_Id := Current_Entity_In_Scope (S);
3008       C_E : Entity_Id := Current_Entity (S);
3009
3010    begin
3011       if Present (E) then
3012          Set_Has_Homonym (E);
3013          Set_Has_Homonym (S);
3014       end if;
3015
3016       Set_Is_Immediately_Visible (S);
3017       Set_Scope (S, Current_Scope);
3018
3019       --  Chain new entity if front of homonym in current scope, so that
3020       --  homonyms are contiguous.
3021
3022       if Present (E)
3023         and then E /= C_E
3024       then
3025          while Homonym (C_E) /= E loop
3026             C_E := Homonym (C_E);
3027          end loop;
3028
3029          Set_Homonym (C_E, S);
3030
3031       else
3032          E := C_E;
3033          Set_Current_Entity (S);
3034       end if;
3035
3036       Set_Homonym (S, E);
3037
3038       Append_Entity (S, Current_Scope);
3039       Set_Public_Status (S);
3040
3041       if Debug_Flag_E then
3042          Write_Str ("New overloaded entity chain: ");
3043          Write_Name (Chars (S));
3044          E := S;
3045
3046          while Present (E) loop
3047             Write_Str (" "); Write_Int (Int (E));
3048             E := Homonym (E);
3049          end loop;
3050
3051          Write_Eol;
3052       end if;
3053
3054       --  Generate warning for hiding
3055
3056       if Warn_On_Hiding
3057         and then Comes_From_Source (S)
3058         and then In_Extended_Main_Source_Unit (S)
3059       then
3060          E := S;
3061          loop
3062             E := Homonym (E);
3063             exit when No (E);
3064
3065             --  Warn unless genuine overloading
3066
3067             if (not Is_Overloadable (E))
3068               or else Subtype_Conformant (E, S)
3069             then
3070                Error_Msg_Sloc := Sloc (E);
3071                Error_Msg_N ("declaration of & hides one#?", S);
3072             end if;
3073          end loop;
3074       end if;
3075    end Enter_Overloaded_Entity;
3076
3077    -----------------------------
3078    -- Find_Corresponding_Spec --
3079    -----------------------------
3080
3081    function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is
3082       Spec       : constant Node_Id   := Specification (N);
3083       Designator : constant Entity_Id := Defining_Entity (Spec);
3084
3085       E : Entity_Id;
3086
3087    begin
3088       E := Current_Entity (Designator);
3089
3090       while Present (E) loop
3091
3092          --  We are looking for a matching spec. It must have the same scope,
3093          --  and the same name, and either be type conformant, or be the case
3094          --  of a library procedure spec and its body (which belong to one
3095          --  another regardless of whether they are type conformant or not).
3096
3097          if Scope (E) = Current_Scope then
3098             if (Current_Scope = Standard_Standard
3099                   or else (Ekind (E) = Ekind (Designator)
3100                 and then
3101                   Type_Conformant (E, Designator)))
3102             then
3103                --  Within an instantiation, we know that spec and body are
3104                --  subtype conformant, because they were subtype conformant
3105                --  in the generic. We choose the subtype-conformant entity
3106                --  here as well, to resolve spurious ambiguities in the
3107                --  instance that were not present in the generic (i.e. when
3108                --  two different types are given the same actual). If we are
3109                --  looking for a spec to match a body, full conformance is
3110                --  expected.
3111
3112                if In_Instance then
3113                   Set_Convention (Designator, Convention (E));
3114
3115                   if Nkind (N) = N_Subprogram_Body
3116                     and then Present (Homonym (E))
3117                     and then not Fully_Conformant (E, Designator)
3118                   then
3119                      goto Next_Entity;
3120
3121                   elsif not Subtype_Conformant (E, Designator) then
3122                      goto Next_Entity;
3123                   end if;
3124                end if;
3125
3126                if not Has_Completion (E) then
3127
3128                   if Nkind (N) /= N_Subprogram_Body_Stub then
3129                      Set_Corresponding_Spec (N, E);
3130                   end if;
3131
3132                   Set_Has_Completion (E);
3133                   return E;
3134
3135                elsif Nkind (Parent (N)) = N_Subunit then
3136
3137                   --  If this is the proper body of a subunit, the completion
3138                   --  flag is set when analyzing the stub.
3139
3140                   return E;
3141
3142                --  If body already exists, this is an error unless the
3143                --  previous declaration is the implicit declaration of
3144                --  a derived subprogram, or this is a spurious overloading
3145                --  in an instance.
3146
3147                elsif No (Alias (E))
3148                  and then not Is_Intrinsic_Subprogram (E)
3149                  and then not In_Instance
3150                then
3151                   Error_Msg_Sloc := Sloc (E);
3152                   if Is_Imported (E) then
3153                      Error_Msg_NE
3154                       ("body not allowed for imported subprogram & declared#",
3155                         N, E);
3156                   else
3157                      Error_Msg_NE ("duplicate body for & declared#", N, E);
3158                   end if;
3159                end if;
3160
3161             elsif Is_Child_Unit (E)
3162               and then
3163                 Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
3164               and then
3165                 Nkind (Parent (Unit_Declaration_Node (Designator)))
3166                   = N_Compilation_Unit
3167             then
3168
3169                --  Child units cannot be overloaded, so a conformance mismatch
3170                --  between body and a previous spec is an error.
3171
3172                Error_Msg_N
3173                  ("body of child unit does not match previous declaration", N);
3174             end if;
3175          end if;
3176
3177          <<Next_Entity>>
3178             E := Homonym (E);
3179       end loop;
3180
3181       --  On exit, we know that no previous declaration of subprogram exists
3182
3183       return Empty;
3184    end Find_Corresponding_Spec;
3185
3186    ----------------------
3187    -- Fully_Conformant --
3188    ----------------------
3189
3190    function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
3191       Result : Boolean;
3192
3193    begin
3194       Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
3195       return Result;
3196    end Fully_Conformant;
3197
3198    ----------------------------------
3199    -- Fully_Conformant_Expressions --
3200    ----------------------------------
3201
3202    function Fully_Conformant_Expressions
3203      (Given_E1 : Node_Id;
3204       Given_E2 : Node_Id)
3205       return     Boolean
3206    is
3207       E1 : constant Node_Id := Original_Node (Given_E1);
3208       E2 : constant Node_Id := Original_Node (Given_E2);
3209       --  We always test conformance on original nodes, since it is possible
3210       --  for analysis and/or expansion to make things look as though they
3211       --  conform when they do not, e.g. by converting 1+2 into 3.
3212
3213       function FCE (Given_E1, Given_E2 : Node_Id) return Boolean
3214         renames Fully_Conformant_Expressions;
3215
3216       function FCL (L1, L2 : List_Id) return Boolean;
3217       --  Compare elements of two lists for conformance. Elements have to
3218       --  be conformant, and actuals inserted as default parameters do not
3219       --  match explicit actuals with the same value.
3220
3221       function FCO (Op_Node, Call_Node : Node_Id) return Boolean;
3222       --  Compare an operator node with a function call.
3223
3224       ---------
3225       -- FCL --
3226       ---------
3227
3228       function FCL (L1, L2 : List_Id) return Boolean is
3229          N1, N2 : Node_Id;
3230
3231       begin
3232          if L1 = No_List then
3233             N1 := Empty;
3234          else
3235             N1 := First (L1);
3236          end if;
3237
3238          if L2 = No_List then
3239             N2 := Empty;
3240          else
3241             N2 := First (L2);
3242          end if;
3243
3244          --  Compare two lists, skipping rewrite insertions (we want to
3245          --  compare the original trees, not the expanded versions!)
3246
3247          loop
3248             if Is_Rewrite_Insertion (N1) then
3249                Next (N1);
3250             elsif Is_Rewrite_Insertion (N2) then
3251                Next (N2);
3252             elsif No (N1) then
3253                return No (N2);
3254             elsif No (N2) then
3255                return False;
3256             elsif not FCE (N1, N2) then
3257                return False;
3258             else
3259                Next (N1);
3260                Next (N2);
3261             end if;
3262          end loop;
3263       end FCL;
3264
3265       ---------
3266       -- FCO --
3267       ---------
3268
3269       function FCO (Op_Node, Call_Node : Node_Id) return Boolean is
3270          Actuals : constant List_Id := Parameter_Associations (Call_Node);
3271          Act     : Node_Id;
3272
3273       begin
3274          if No (Actuals)
3275             or else Entity (Op_Node) /= Entity (Name (Call_Node))
3276          then
3277             return False;
3278
3279          else
3280             Act := First (Actuals);
3281
3282             if Nkind (Op_Node) in N_Binary_Op then
3283
3284                if not FCE (Left_Opnd (Op_Node), Act) then
3285                   return False;
3286                end if;
3287
3288                Next (Act);
3289             end if;
3290
3291             return Present (Act)
3292               and then FCE (Right_Opnd (Op_Node), Act)
3293               and then No (Next (Act));
3294          end if;
3295       end FCO;
3296
3297    --  Start of processing for Fully_Conformant_Expressions
3298
3299    begin
3300       --  Non-conformant if paren count does not match. Note: if some idiot
3301       --  complains that we don't do this right for more than 3 levels of
3302       --  parentheses, they will be treated with the respect they deserve :-)
3303
3304       if Paren_Count (E1) /= Paren_Count (E2) then
3305          return False;
3306
3307       --  If same entities are referenced, then they are conformant
3308       --  even if they have different forms (RM 8.3.1(19-20)).
3309
3310       elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
3311          if Present (Entity (E1)) then
3312             return Entity (E1) = Entity (E2)
3313               or else (Chars (Entity (E1)) = Chars (Entity (E2))
3314                         and then Ekind (Entity (E1)) = E_Discriminant
3315                         and then Ekind (Entity (E2)) = E_In_Parameter);
3316
3317          elsif Nkind (E1) = N_Expanded_Name
3318            and then Nkind (E2) = N_Expanded_Name
3319            and then Nkind (Selector_Name (E1)) = N_Character_Literal
3320            and then Nkind (Selector_Name (E2)) = N_Character_Literal
3321          then
3322             return Chars (Selector_Name (E1)) = Chars (Selector_Name (E2));
3323
3324          else
3325             --  Identifiers in component associations don't always have
3326             --  entities, but their names must conform.
3327
3328             return Nkind  (E1) = N_Identifier
3329               and then Nkind (E2) = N_Identifier
3330               and then Chars (E1) = Chars (E2);
3331          end if;
3332
3333       elsif Nkind (E1) = N_Character_Literal
3334         and then Nkind (E2) = N_Expanded_Name
3335       then
3336          return Nkind (Selector_Name (E2)) = N_Character_Literal
3337            and then Chars (E1) = Chars (Selector_Name (E2));
3338
3339       elsif Nkind (E2) = N_Character_Literal
3340         and then Nkind (E1) = N_Expanded_Name
3341       then
3342          return Nkind (Selector_Name (E1)) = N_Character_Literal
3343            and then Chars (E2) = Chars (Selector_Name (E1));
3344
3345       elsif Nkind (E1) in N_Op
3346         and then Nkind (E2) = N_Function_Call
3347       then
3348          return FCO (E1, E2);
3349
3350       elsif Nkind (E2) in N_Op
3351         and then Nkind (E1) = N_Function_Call
3352       then
3353          return FCO (E2, E1);
3354
3355       --  Otherwise we must have the same syntactic entity
3356
3357       elsif Nkind (E1) /= Nkind (E2) then
3358          return False;
3359
3360       --  At this point, we specialize by node type
3361
3362       else
3363          case Nkind (E1) is
3364
3365             when N_Aggregate =>
3366                return
3367                  FCL (Expressions (E1), Expressions (E2))
3368                    and then FCL (Component_Associations (E1),
3369                                  Component_Associations (E2));
3370
3371             when N_Allocator =>
3372                if Nkind (Expression (E1)) = N_Qualified_Expression
3373                     or else
3374                   Nkind (Expression (E2)) = N_Qualified_Expression
3375                then
3376                   return FCE (Expression (E1), Expression (E2));
3377
3378                --  Check that the subtype marks and any constraints
3379                --  are conformant
3380
3381                else
3382                   declare
3383                      Indic1 : constant Node_Id := Expression (E1);
3384                      Indic2 : constant Node_Id := Expression (E2);
3385                      Elt1   : Node_Id;
3386                      Elt2   : Node_Id;
3387
3388                   begin
3389                      if Nkind (Indic1) /= N_Subtype_Indication then
3390                         return
3391                           Nkind (Indic2) /= N_Subtype_Indication
3392                             and then Entity (Indic1) = Entity (Indic2);
3393
3394                      elsif Nkind (Indic2) /= N_Subtype_Indication then
3395                         return
3396                           Nkind (Indic1) /= N_Subtype_Indication
3397                             and then Entity (Indic1) = Entity (Indic2);
3398
3399                      else
3400                         if Entity (Subtype_Mark (Indic1)) /=
3401                           Entity (Subtype_Mark (Indic2))
3402                         then
3403                            return False;
3404                         end if;
3405
3406                         Elt1 := First (Constraints (Constraint (Indic1)));
3407                         Elt2 := First (Constraints (Constraint (Indic2)));
3408
3409                         while Present (Elt1) and then Present (Elt2) loop
3410                            if not FCE (Elt1, Elt2) then
3411                               return False;
3412                            end if;
3413
3414                            Next (Elt1);
3415                            Next (Elt2);
3416                         end loop;
3417
3418                         return True;
3419                      end if;
3420                   end;
3421                end if;
3422
3423             when N_Attribute_Reference =>
3424                return
3425                  Attribute_Name (E1) = Attribute_Name (E2)
3426                    and then FCL (Expressions (E1), Expressions (E2));
3427
3428             when N_Binary_Op =>
3429                return
3430                  Entity (E1) = Entity (E2)
3431                    and then FCE (Left_Opnd  (E1), Left_Opnd  (E2))
3432                    and then FCE (Right_Opnd (E1), Right_Opnd (E2));
3433
3434             when N_And_Then | N_Or_Else | N_In | N_Not_In =>
3435                return
3436                  FCE (Left_Opnd  (E1), Left_Opnd  (E2))
3437                    and then
3438                  FCE (Right_Opnd (E1), Right_Opnd (E2));
3439
3440             when N_Character_Literal =>
3441                return
3442                  Char_Literal_Value (E1) = Char_Literal_Value (E2);
3443
3444             when N_Component_Association =>
3445                return
3446                  FCL (Choices (E1), Choices (E2))
3447                    and then FCE (Expression (E1), Expression (E2));
3448
3449             when N_Conditional_Expression =>
3450                return
3451                  FCL (Expressions (E1), Expressions (E2));
3452
3453             when N_Explicit_Dereference =>
3454                return
3455                  FCE (Prefix (E1), Prefix (E2));
3456
3457             when N_Extension_Aggregate =>
3458                return
3459                  FCL (Expressions (E1), Expressions (E2))
3460                    and then Null_Record_Present (E1) =
3461                             Null_Record_Present (E2)
3462                    and then FCL (Component_Associations (E1),
3463                                Component_Associations (E2));
3464
3465             when N_Function_Call =>
3466                return
3467                  FCE (Name (E1), Name (E2))
3468                    and then FCL (Parameter_Associations (E1),
3469                                  Parameter_Associations (E2));
3470
3471             when N_Indexed_Component =>
3472                return
3473                  FCE (Prefix (E1), Prefix (E2))
3474                    and then FCL (Expressions (E1), Expressions (E2));
3475
3476             when N_Integer_Literal =>
3477                return (Intval (E1) = Intval (E2));
3478
3479             when N_Null =>
3480                return True;
3481
3482             when N_Operator_Symbol =>
3483                return
3484                  Chars (E1) = Chars (E2);
3485
3486             when N_Others_Choice =>
3487                return True;
3488
3489             when N_Parameter_Association =>
3490                return
3491
3492                  Chars (Selector_Name (E1))  = Chars (Selector_Name (E2))
3493                    and then FCE (Explicit_Actual_Parameter (E1),
3494                                  Explicit_Actual_Parameter (E2));
3495
3496             when N_Qualified_Expression =>
3497                return
3498                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
3499                    and then FCE (Expression (E1), Expression (E2));
3500
3501             when N_Range =>
3502                return
3503                  FCE (Low_Bound (E1), Low_Bound (E2))
3504                    and then FCE (High_Bound (E1), High_Bound (E2));
3505
3506             when N_Real_Literal =>
3507                return (Realval (E1) = Realval (E2));
3508
3509             when N_Selected_Component =>
3510                return
3511                  FCE (Prefix (E1), Prefix (E2))
3512                    and then FCE (Selector_Name (E1), Selector_Name (E2));
3513
3514             when N_Slice =>
3515                return
3516                  FCE (Prefix (E1), Prefix (E2))
3517                    and then FCE (Discrete_Range (E1), Discrete_Range (E2));
3518
3519             when N_String_Literal =>
3520                declare
3521                   S1 : constant String_Id := Strval (E1);
3522                   S2 : constant String_Id := Strval (E2);
3523                   L1 : constant Nat       := String_Length (S1);
3524                   L2 : constant Nat       := String_Length (S2);
3525
3526                begin
3527                   if L1 /= L2 then
3528                      return False;
3529
3530                   else
3531                      for J in 1 .. L1 loop
3532                         if Get_String_Char (S1, J) /=
3533                            Get_String_Char (S2, J)
3534                         then
3535                            return False;
3536                         end if;
3537                      end loop;
3538
3539                      return True;
3540                   end if;
3541                end;
3542
3543             when N_Type_Conversion =>
3544                return
3545                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
3546                    and then FCE (Expression (E1), Expression (E2));
3547
3548             when N_Unary_Op =>
3549                return
3550                  Entity (E1) = Entity (E2)
3551                    and then FCE (Right_Opnd (E1), Right_Opnd (E2));
3552
3553             when N_Unchecked_Type_Conversion =>
3554                return
3555                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
3556                    and then FCE (Expression (E1), Expression (E2));
3557
3558             --  All other node types cannot appear in this context. Strictly
3559             --  we should raise a fatal internal error. Instead we just ignore
3560             --  the nodes. This means that if anyone makes a mistake in the
3561             --  expander and mucks an expression tree irretrievably, the
3562             --  result will be a failure to detect a (probably very obscure)
3563             --  case of non-conformance, which is better than bombing on some
3564             --  case where two expressions do in fact conform.
3565
3566             when others =>
3567                return True;
3568
3569          end case;
3570       end if;
3571    end Fully_Conformant_Expressions;
3572
3573    --------------------
3574    -- Install_Entity --
3575    --------------------
3576
3577    procedure Install_Entity (E : Entity_Id) is
3578       Prev : constant Entity_Id := Current_Entity (E);
3579
3580    begin
3581       Set_Is_Immediately_Visible (E);
3582       Set_Current_Entity (E);
3583       Set_Homonym (E, Prev);
3584    end Install_Entity;
3585
3586    ---------------------
3587    -- Install_Formals --
3588    ---------------------
3589
3590    procedure Install_Formals (Id : Entity_Id) is
3591       F : Entity_Id;
3592
3593    begin
3594       F := First_Formal (Id);
3595
3596       while Present (F) loop
3597          Install_Entity (F);
3598          Next_Formal (F);
3599       end loop;
3600    end Install_Formals;
3601
3602    ---------------------------------
3603    -- Is_Non_Overriding_Operation --
3604    ---------------------------------
3605
3606    function Is_Non_Overriding_Operation
3607      (Prev_E : Entity_Id;
3608       New_E  : Entity_Id)
3609       return Boolean
3610    is
3611       Formal : Entity_Id;
3612       F_Typ  : Entity_Id;
3613       G_Typ  : Entity_Id := Empty;
3614
3615       function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
3616       --  If F_Type is a derived type associated with a generic actual
3617       --  subtype, then return its Generic_Parent_Type attribute, else
3618       --  return Empty.
3619
3620       function Types_Correspond
3621         (P_Type : Entity_Id;
3622          N_Type : Entity_Id)
3623          return   Boolean;
3624       --  Returns true if and only if the types (or designated types
3625       --  in the case of anonymous access types) are the same or N_Type
3626       --  is derived directly or indirectly from P_Type.
3627
3628       -----------------------------
3629       -- Get_Generic_Parent_Type --
3630       -----------------------------
3631
3632       function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is
3633          G_Typ : Entity_Id;
3634          Indic : Node_Id;
3635
3636       begin
3637          if Is_Derived_Type (F_Typ)
3638            and then Nkind (Parent (F_Typ)) = N_Full_Type_Declaration
3639          then
3640             --  The tree must be traversed to determine the parent
3641             --  subtype in the generic unit, which unfortunately isn't
3642             --  always available via semantic attributes. ???
3643             --  (Note: The use of Original_Node is needed for cases
3644             --  where a full derived type has been rewritten.)
3645
3646             Indic := Subtype_Indication
3647                        (Type_Definition (Original_Node (Parent (F_Typ))));
3648
3649             if Nkind (Indic) = N_Subtype_Indication then
3650                G_Typ := Entity (Subtype_Mark (Indic));
3651             else
3652                G_Typ := Entity (Indic);
3653             end if;
3654
3655             if Nkind (Parent (G_Typ)) = N_Subtype_Declaration
3656               and then Present (Generic_Parent_Type (Parent (G_Typ)))
3657             then
3658                return Generic_Parent_Type (Parent (G_Typ));
3659             end if;
3660          end if;
3661
3662          return Empty;
3663       end Get_Generic_Parent_Type;
3664
3665       ----------------------
3666       -- Types_Correspond --
3667       ----------------------
3668
3669       function Types_Correspond
3670         (P_Type : Entity_Id;
3671          N_Type : Entity_Id)
3672          return   Boolean
3673       is
3674          Prev_Type : Entity_Id := Base_Type (P_Type);
3675          New_Type  : Entity_Id := Base_Type (N_Type);
3676
3677       begin
3678          if Ekind (Prev_Type) = E_Anonymous_Access_Type then
3679             Prev_Type := Designated_Type (Prev_Type);
3680          end if;
3681
3682          if Ekind (New_Type) = E_Anonymous_Access_Type then
3683             New_Type := Designated_Type (New_Type);
3684          end if;
3685
3686          if Prev_Type = New_Type then
3687             return True;
3688
3689          elsif not Is_Class_Wide_Type (New_Type) then
3690             while Etype (New_Type) /= New_Type loop
3691                New_Type := Etype (New_Type);
3692                if New_Type = Prev_Type then
3693                   return True;
3694                end if;
3695             end loop;
3696          end if;
3697          return False;
3698       end Types_Correspond;
3699
3700    --  Start of processing for Is_Non_Overriding_Operation
3701
3702    begin
3703       --  In the case where both operations are implicit derived
3704       --  subprograms then neither overrides the other. This can
3705       --  only occur in certain obscure cases (e.g., derivation
3706       --  from homographs created in a generic instantiation).
3707
3708       if Present (Alias (Prev_E)) and then Present (Alias (New_E)) then
3709          return True;
3710
3711       elsif Ekind (Current_Scope) = E_Package
3712         and then Is_Generic_Instance (Current_Scope)
3713         and then In_Private_Part (Current_Scope)
3714         and then Comes_From_Source (New_E)
3715       then
3716          --  We examine the formals and result subtype of the inherited
3717          --  operation, to determine whether their type is derived from
3718          --  (the instance of) a generic type.
3719
3720          Formal := First_Formal (Prev_E);
3721
3722          while Present (Formal) loop
3723             F_Typ := Base_Type (Etype (Formal));
3724
3725             if Ekind (F_Typ) = E_Anonymous_Access_Type then
3726                F_Typ := Designated_Type (F_Typ);
3727             end if;
3728
3729             G_Typ := Get_Generic_Parent_Type (F_Typ);
3730
3731             Next_Formal (Formal);
3732          end loop;
3733
3734          if not Present (G_Typ) and then Ekind (Prev_E) = E_Function then
3735             G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
3736          end if;
3737
3738          if No (G_Typ) then
3739             return False;
3740          end if;
3741
3742          --  If the generic type is a private type, then the original
3743          --  operation was not overriding in the generic, because there was
3744          --  no primitive operation to override.
3745
3746          if Nkind (Parent (G_Typ)) = N_Formal_Type_Declaration
3747            and then Nkind (Formal_Type_Definition (Parent (G_Typ))) =
3748              N_Formal_Private_Type_Definition
3749          then
3750             return True;
3751
3752          --  The generic parent type is the ancestor of a formal derived
3753          --  type declaration. We need to check whether it has a primitive
3754          --  operation that should be overridden by New_E in the generic.
3755
3756          else
3757             declare
3758                P_Formal : Entity_Id;
3759                N_Formal : Entity_Id;
3760                P_Typ    : Entity_Id;
3761                N_Typ    : Entity_Id;
3762                P_Prim   : Entity_Id;
3763                Prim_Elt : Elmt_Id := First_Elmt (Primitive_Operations (G_Typ));
3764
3765             begin
3766                while Present (Prim_Elt) loop
3767                   P_Prim := Node (Prim_Elt);
3768                   if Chars (P_Prim) = Chars (New_E)
3769                     and then Ekind (P_Prim) = Ekind (New_E)
3770                   then
3771                      P_Formal := First_Formal (P_Prim);
3772                      N_Formal := First_Formal (New_E);
3773                      while Present (P_Formal) and then Present (N_Formal) loop
3774                         P_Typ := Etype (P_Formal);
3775                         N_Typ := Etype (N_Formal);
3776
3777                         if not Types_Correspond (P_Typ, N_Typ) then
3778                            exit;
3779                         end if;
3780
3781                         Next_Entity (P_Formal);
3782                         Next_Entity (N_Formal);
3783                      end loop;
3784
3785                      --  Found a matching primitive operation belonging to
3786                      --  the formal ancestor type, so the new subprogram
3787                      --  is overriding.
3788
3789                      if not Present (P_Formal)
3790                        and then not Present (N_Formal)
3791                        and then (Ekind (New_E) /= E_Function
3792                                   or else
3793                                  Types_Correspond
3794                                    (Etype (P_Prim), Etype (New_E)))
3795                      then
3796                         return False;
3797                      end if;
3798                   end if;
3799
3800                   Next_Elmt (Prim_Elt);
3801                end loop;
3802
3803                --  If no match found, then the new subprogram does
3804                --  not override in the generic (nor in the instance).
3805
3806                return True;
3807             end;
3808          end if;
3809       else
3810          return False;
3811       end if;
3812    end Is_Non_Overriding_Operation;
3813
3814    ------------------------------
3815    -- Make_Inequality_Operator --
3816    ------------------------------
3817
3818    --  S is the defining identifier of an equality operator. We build a
3819    --  subprogram declaration with the right signature. This operation is
3820    --  intrinsic, because it is always expanded as the negation of the
3821    --  call to the equality function.
3822
3823    procedure Make_Inequality_Operator (S : Entity_Id) is
3824       Loc     : constant Source_Ptr := Sloc (S);
3825       Decl    : Node_Id;
3826       Formals : List_Id;
3827       Op_Name : Entity_Id;
3828
3829       A : Entity_Id;
3830       B : Entity_Id;
3831
3832    begin
3833       --  Check that equality was properly defined.
3834
3835       if  No (Next_Formal (First_Formal (S))) then
3836          return;
3837       end if;
3838
3839       A := Make_Defining_Identifier (Loc, Chars (First_Formal (S)));
3840       B := Make_Defining_Identifier (Loc,
3841              Chars (Next_Formal (First_Formal (S))));
3842
3843       Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
3844
3845       Formals := New_List (
3846         Make_Parameter_Specification (Loc,
3847           Defining_Identifier => A,
3848           Parameter_Type =>
3849             New_Reference_To (Etype (First_Formal (S)), Loc)),
3850
3851         Make_Parameter_Specification (Loc,
3852           Defining_Identifier => B,
3853           Parameter_Type =>
3854             New_Reference_To (Etype (Next_Formal (First_Formal (S))), Loc)));
3855
3856       Decl :=
3857         Make_Subprogram_Declaration (Loc,
3858           Specification =>
3859             Make_Function_Specification (Loc,
3860               Defining_Unit_Name => Op_Name,
3861               Parameter_Specifications => Formals,
3862               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)));
3863
3864       --  Insert inequality right after equality if it is explicit or after
3865       --  the derived type when implicit. These entities are created only
3866       --  for visibility purposes, and eventually replaced in the course of
3867       --  expansion, so they do not need to be attached to the tree and seen
3868       --  by the back-end. Keeping them internal also avoids spurious freezing
3869       --  problems. The parent field is set simply to make analysis safe.
3870
3871       if No (Alias (S)) then
3872          Set_Parent (Decl, Parent (Unit_Declaration_Node (S)));
3873       else
3874          Set_Parent (Decl, Parent (Parent (Etype (First_Formal (S)))));
3875       end if;
3876
3877       Mark_Rewrite_Insertion (Decl);
3878       Set_Is_Intrinsic_Subprogram (Op_Name);
3879       Analyze (Decl);
3880       Set_Has_Completion (Op_Name);
3881       Set_Corresponding_Equality (Op_Name, S);
3882       Set_Is_Abstract (Op_Name, Is_Abstract (S));
3883
3884    end Make_Inequality_Operator;
3885
3886    ----------------------
3887    -- May_Need_Actuals --
3888    ----------------------
3889
3890    procedure May_Need_Actuals (Fun : Entity_Id) is
3891       F : Entity_Id;
3892       B : Boolean;
3893
3894    begin
3895       F := First_Formal (Fun);
3896       B := True;
3897
3898       while Present (F) loop
3899          if No (Default_Value (F)) then
3900             B := False;
3901             exit;
3902          end if;
3903
3904          Next_Formal (F);
3905       end loop;
3906
3907       Set_Needs_No_Actuals (Fun, B);
3908    end May_Need_Actuals;
3909
3910    ---------------------
3911    -- Mode_Conformant --
3912    ---------------------
3913
3914    function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
3915       Result : Boolean;
3916
3917    begin
3918       Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
3919       return Result;
3920    end Mode_Conformant;
3921
3922    ---------------------------
3923    -- New_Overloaded_Entity --
3924    ---------------------------
3925
3926    procedure New_Overloaded_Entity
3927      (S            : Entity_Id;
3928       Derived_Type : Entity_Id := Empty)
3929    is
3930       E        : Entity_Id := Current_Entity_In_Scope (S);
3931       Prev_Vis : Entity_Id := Empty;
3932
3933       function Is_Private_Declaration (E : Entity_Id) return Boolean;
3934       --  Check that E is declared in the private part of the current package,
3935       --  or in the package body, where it may hide a previous declaration.
3936       --  We can' use In_Private_Part by itself because this flag is also
3937       --  set when freezing entities, so we must examine the place of the
3938       --  declaration in the tree, and recognize wrapper packages as well.
3939
3940       procedure Maybe_Primitive_Operation (Overriding : Boolean := False);
3941       --  If the subprogram being analyzed is a primitive operation of
3942       --  the type of one of its formals, set the corresponding flag.
3943
3944       ----------------------------
3945       -- Is_Private_Declaration --
3946       ----------------------------
3947
3948       function Is_Private_Declaration (E : Entity_Id) return Boolean is
3949          Priv_Decls : List_Id;
3950          Decl       : constant Node_Id := Unit_Declaration_Node (E);
3951
3952       begin
3953          if Is_Package (Current_Scope)
3954            and then In_Private_Part (Current_Scope)
3955          then
3956             Priv_Decls :=
3957               Private_Declarations (
3958                 Specification (Unit_Declaration_Node (Current_Scope)));
3959
3960             return In_Package_Body (Current_Scope)
3961               or else List_Containing (Decl) = Priv_Decls
3962               or else (Nkind (Parent (Decl)) = N_Package_Specification
3963                          and then not Is_Compilation_Unit (
3964                            Defining_Entity (Parent (Decl)))
3965                          and then List_Containing (Parent (Parent (Decl)))
3966                            = Priv_Decls);
3967          else
3968             return False;
3969          end if;
3970       end Is_Private_Declaration;
3971
3972       -------------------------------
3973       -- Maybe_Primitive_Operation --
3974       -------------------------------
3975
3976       procedure Maybe_Primitive_Operation (Overriding : Boolean := False) is
3977          Formal : Entity_Id;
3978          F_Typ  : Entity_Id;
3979          B_Typ  : Entity_Id;
3980
3981          function Visible_Part_Type (T : Entity_Id) return Boolean;
3982          --  Returns true if T is declared in the visible part of
3983          --  the current package scope; otherwise returns false.
3984          --  Assumes that T is declared in a package.
3985
3986          procedure Check_Private_Overriding (T : Entity_Id);
3987          --  Checks that if a primitive abstract subprogram of a visible
3988          --  abstract type is declared in a private part, then it must
3989          --  override an abstract subprogram declared in the visible part.
3990          --  Also checks that if a primitive function with a controlling
3991          --  result is declared in a private part, then it must override
3992          --  a function declared in the visible part.
3993
3994          ------------------------------
3995          -- Check_Private_Overriding --
3996          ------------------------------
3997
3998          procedure Check_Private_Overriding (T : Entity_Id) is
3999          begin
4000             if Ekind (Current_Scope) = E_Package
4001               and then In_Private_Part (Current_Scope)
4002               and then Visible_Part_Type (T)
4003               and then not In_Instance
4004             then
4005                if Is_Abstract (T)
4006                  and then Is_Abstract (S)
4007                  and then (not Overriding or else not Is_Abstract (E))
4008                then
4009                   Error_Msg_N ("abstract subprograms must be visible "
4010                                 & "('R'M 3.9.3(10))!", S);
4011
4012                elsif Ekind (S) = E_Function
4013                  and then Is_Tagged_Type (T)
4014                  and then T = Base_Type (Etype (S))
4015                  and then not Overriding
4016                then
4017                   Error_Msg_N
4018                     ("private function with tagged result must"
4019                      & " override visible-part function", S);
4020                   Error_Msg_N
4021                     ("\move subprogram to the visible part"
4022                      & " ('R'M 3.9.3(10))", S);
4023                end if;
4024             end if;
4025          end Check_Private_Overriding;
4026
4027          -----------------------
4028          -- Visible_Part_Type --
4029          -----------------------
4030
4031          function Visible_Part_Type (T : Entity_Id) return Boolean is
4032             P : constant Node_Id := Unit_Declaration_Node (Scope (T));
4033             N : Node_Id;
4034
4035          begin
4036             --  If the entity is a private type, then it must be
4037             --  declared in a visible part.
4038
4039             if Ekind (T) in Private_Kind then
4040                return True;
4041             end if;
4042
4043             --  Otherwise, we traverse the visible part looking for its
4044             --  corresponding declaration. We cannot use the declaration
4045             --  node directly because in the private part the entity of a
4046             --  private type is the one in the full view, which does not
4047             --  indicate that it is the completion of something visible.
4048
4049             N := First (Visible_Declarations (Specification (P)));
4050             while Present (N) loop
4051                if Nkind (N) = N_Full_Type_Declaration
4052                  and then Present (Defining_Identifier (N))
4053                  and then T = Defining_Identifier (N)
4054                then
4055                   return True;
4056
4057                elsif (Nkind (N) = N_Private_Type_Declaration
4058                        or else
4059                       Nkind (N) = N_Private_Extension_Declaration)
4060                  and then Present (Defining_Identifier (N))
4061                  and then T = Full_View (Defining_Identifier (N))
4062                then
4063                   return True;
4064                end if;
4065
4066                Next (N);
4067             end loop;
4068
4069             return False;
4070          end Visible_Part_Type;
4071
4072       --  Start of processing for Maybe_Primitive_Operation
4073
4074       begin
4075          if not Comes_From_Source (S) then
4076             null;
4077
4078          elsif (Ekind (Current_Scope) = E_Package
4079                  and then not In_Package_Body (Current_Scope))
4080            or else Overriding
4081          then
4082             --  For function, check return type
4083
4084             if Ekind (S) = E_Function then
4085                B_Typ := Base_Type (Etype (S));
4086
4087                if Scope (B_Typ) = Current_Scope then
4088                   Set_Has_Primitive_Operations (B_Typ);
4089                   Check_Private_Overriding (B_Typ);
4090                end if;
4091             end if;
4092
4093             --  For all subprograms, check formals
4094
4095             Formal := First_Formal (S);
4096             while Present (Formal) loop
4097                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
4098                   F_Typ := Designated_Type (Etype (Formal));
4099                else
4100                   F_Typ := Etype (Formal);
4101                end if;
4102
4103                B_Typ := Base_Type (F_Typ);
4104
4105                if Scope (B_Typ) = Current_Scope then
4106                   Set_Has_Primitive_Operations (B_Typ);
4107                   Check_Private_Overriding (B_Typ);
4108                end if;
4109
4110                Next_Formal (Formal);
4111             end loop;
4112          end if;
4113       end Maybe_Primitive_Operation;
4114
4115    --  Start of processing for New_Overloaded_Entity
4116
4117    begin
4118       if No (E) then
4119          Enter_Overloaded_Entity (S);
4120          Check_Dispatching_Operation (S, Empty);
4121          Maybe_Primitive_Operation;
4122
4123       elsif not Is_Overloadable (E) then
4124
4125          --  Check for spurious conflict produced by a subprogram that has the
4126          --  same name as that of the enclosing generic package. The conflict
4127          --  occurs within an instance, between the subprogram and the renaming
4128          --  declaration for the package. After the subprogram, the package
4129          --  renaming declaration becomes hidden.
4130
4131          if Ekind (E) = E_Package
4132            and then Present (Renamed_Object (E))
4133            and then Renamed_Object (E) = Current_Scope
4134            and then Nkind (Parent (Renamed_Object (E))) =
4135                                                      N_Package_Specification
4136            and then Present (Generic_Parent (Parent (Renamed_Object (E))))
4137          then
4138             Set_Is_Hidden (E);
4139             Set_Is_Immediately_Visible (E, False);
4140             Enter_Overloaded_Entity (S);
4141             Set_Homonym (S, Homonym (E));
4142             Check_Dispatching_Operation (S, Empty);
4143
4144          --  If the subprogram is implicit it is hidden by the previous
4145          --  declaration. However if it is dispatching, it must appear in
4146          --  the dispatch table anyway, because it can be dispatched to
4147          --  even if it cannot be called directly.
4148
4149          elsif Present (Alias (S))
4150            and then not Comes_From_Source (S)
4151          then
4152             Set_Scope (S, Current_Scope);
4153
4154             if Is_Dispatching_Operation (Alias (S)) then
4155                Check_Dispatching_Operation (S, Empty);
4156             end if;
4157
4158             return;
4159
4160          else
4161             Error_Msg_Sloc := Sloc (E);
4162             Error_Msg_N ("& conflicts with declaration#", S);
4163
4164             --  Useful additional warning.
4165
4166             if Is_Generic_Unit (E) then
4167                Error_Msg_N ("\previous generic unit cannot be overloaded", S);
4168             end if;
4169
4170             return;
4171          end if;
4172
4173       else
4174          --  E exists and is overloadable. Determine whether S is the body
4175          --  of E, a new overloaded entity with a different signature, or
4176          --  an error altogether.
4177
4178          while Present (E) loop
4179             if Scope (E) /= Current_Scope then
4180                null;
4181
4182             elsif Type_Conformant (E, S) then
4183
4184                --  If the old and new entities have the same profile and
4185                --  one is not the body of the other, then this is an error,
4186                --  unless one of them is implicitly declared.
4187
4188                --  There are some cases when both can be implicit, for example
4189                --  when both a literal and a function that overrides it are
4190                --  inherited in a derivation, or when an inhertited operation
4191                --  of a tagged full type overrides the ineherited operation of
4192                --  a private extension. Ada 83 had a special rule for the
4193                --  the literal case. In Ada95, the later implicit operation
4194                --  hides the former, and the literal is always the former.
4195                --  In the odd case where both are derived operations declared
4196                --  at the same point, both operations should be declared,
4197                --  and in that case we bypass the following test and proceed
4198                --  to the next part (this can only occur for certain obscure
4199                --  cases involving homographs in instances and can't occur for
4200                --  dispatching operations ???). Note that the following
4201                --  condition is less than clear. For example, it's not at
4202                --  all clear why there's a test for E_Entry here. ???
4203
4204                if Present (Alias (S))
4205                  and then (No (Alias (E))
4206                             or else Comes_From_Source (E)
4207                             or else Is_Dispatching_Operation (E))
4208                  and then
4209                    (Ekind (E) = E_Entry
4210                      or else Ekind (E) /= E_Enumeration_Literal)
4211                then
4212                   --  When an derived operation is overloaded it may be due
4213                   --  to the fact that the full view of a private extension
4214                   --  re-inherits. It has to be dealt with.
4215
4216                   if Is_Package (Current_Scope)
4217                     and then In_Private_Part (Current_Scope)
4218                   then
4219                      Check_Operation_From_Private_View (S, E);
4220                   end if;
4221
4222                   --  In any case the implicit operation remains hidden by
4223                   --  the existing declaration.
4224
4225                   return;
4226
4227                   --  Within an instance, the renaming declarations for
4228                   --  actual subprograms may become ambiguous, but they do
4229                   --  not hide each other.
4230
4231                elsif Ekind (E) /= E_Entry
4232                  and then not Comes_From_Source (E)
4233                  and then not Is_Generic_Instance (E)
4234                  and then (Present (Alias (E))
4235                             or else Is_Intrinsic_Subprogram (E))
4236                  and then (not In_Instance
4237                             or else No (Parent (E))
4238                             or else Nkind (Unit_Declaration_Node (E)) /=
4239                                N_Subprogram_Renaming_Declaration)
4240                then
4241                   --  A subprogram child unit is not allowed to override
4242                   --  an inherited subprogram (10.1.1(20)).
4243
4244                   if Is_Child_Unit (S) then
4245                      Error_Msg_N
4246                        ("child unit overrides inherited subprogram in parent",
4247                         S);
4248                      return;
4249                   end if;
4250
4251                   if Is_Non_Overriding_Operation (E, S) then
4252                      Enter_Overloaded_Entity (S);
4253                      if not Present (Derived_Type)
4254                        or else Is_Tagged_Type (Derived_Type)
4255                      then
4256                         Check_Dispatching_Operation (S, Empty);
4257                      end if;
4258
4259                      return;
4260                   end if;
4261
4262                   --  E is a derived operation or an internal operator which
4263                   --  is being overridden. Remove E from further visibility.
4264                   --  Furthermore, if E is a dispatching operation, it must be
4265                   --  replaced in the list of primitive operations of its type
4266                   --  (see Override_Dispatching_Operation).
4267
4268                   declare
4269                      Prev : Entity_Id;
4270
4271                   begin
4272                      Prev := First_Entity (Current_Scope);
4273
4274                      while Present (Prev)
4275                        and then Next_Entity (Prev) /= E
4276                      loop
4277                         Next_Entity (Prev);
4278                      end loop;
4279
4280                      --  It is possible for E to be in the current scope and
4281                      --  yet not in the entity chain. This can only occur in a
4282                      --  generic context where E is an implicit concatenation
4283                      --  in the formal part, because in a generic body the
4284                      --  entity chain starts with the formals.
4285
4286                      pragma Assert
4287                        (Present (Prev) or else Chars (E) = Name_Op_Concat);
4288
4289                      --  E must be removed both from the entity_list of the
4290                      --  current scope, and from the visibility chain
4291
4292                      if Debug_Flag_E then
4293                         Write_Str ("Override implicit operation ");
4294                         Write_Int (Int (E));
4295                         Write_Eol;
4296                      end if;
4297
4298                      --  If E is a predefined concatenation, it stands for four
4299                      --  different operations. As a result, a single explicit
4300                      --  declaration does not hide it. In a possible ambiguous
4301                      --  situation, Disambiguate chooses the user-defined op,
4302                      --  so it is correct to retain the previous internal one.
4303
4304                      if Chars (E) /= Name_Op_Concat
4305                        or else Ekind (E) /= E_Operator
4306                      then
4307                         --  For nondispatching derived operations that are
4308                         --  overridden by a subprogram declared in the private
4309                         --  part of a package, we retain the derived subprogram
4310                         --  but mark it as not immediately visible. If the
4311                         --  derived operation was declared in the visible part
4312                         --  then this ensures that it will still be visible
4313                         --  outside the package with the proper signature
4314                         --  (calls from outside must also be directed to this
4315                         --  version rather than the overriding one, unlike the
4316                         --  dispatching case). Calls from inside the package
4317                         --  will still resolve to the overriding subprogram
4318                         --  since the derived one is marked as not visible
4319                         --  within the package.
4320
4321                         --  If the private operation is dispatching, we achieve
4322                         --  the overriding by keeping the implicit operation
4323                         --  but setting its alias to be the overring one. In
4324                         --  this fashion the proper body is executed in all
4325                         --  cases, but the original signature is used outside
4326                         --  of the package.
4327
4328                         --  If the overriding is not in the private part, we
4329                         --  remove the implicit operation altogether.
4330
4331                         if Is_Private_Declaration (S) then
4332
4333                            if not Is_Dispatching_Operation (E) then
4334                               Set_Is_Immediately_Visible (E, False);
4335                            else
4336
4337                               --  work done in Override_Dispatching_Operation.
4338
4339                               null;
4340                            end if;
4341                         else
4342
4343                            --  Find predecessor of E in Homonym chain.
4344
4345                            if E = Current_Entity (E) then
4346                               Prev_Vis := Empty;
4347                            else
4348                               Prev_Vis := Current_Entity (E);
4349                               while Homonym (Prev_Vis) /= E loop
4350                                  Prev_Vis := Homonym (Prev_Vis);
4351                               end loop;
4352                            end if;
4353
4354                            if Prev_Vis /= Empty then
4355
4356                               --  Skip E in the visibility chain
4357
4358                               Set_Homonym (Prev_Vis, Homonym (E));
4359
4360                            else
4361                               Set_Name_Entity_Id (Chars (E), Homonym (E));
4362                            end if;
4363
4364                            Set_Next_Entity (Prev, Next_Entity (E));
4365
4366                            if No (Next_Entity (Prev)) then
4367                               Set_Last_Entity (Current_Scope, Prev);
4368                            end if;
4369
4370                         end if;
4371                      end if;
4372
4373                      Enter_Overloaded_Entity (S);
4374
4375                      if Is_Dispatching_Operation (E) then
4376                         --  An overriding dispatching subprogram inherits
4377                         --  the convention of the overridden subprogram
4378                         --  (by AI-117).
4379
4380                         Set_Convention (S, Convention (E));
4381
4382                         Check_Dispatching_Operation (S, E);
4383                      else
4384                         Check_Dispatching_Operation (S, Empty);
4385                      end if;
4386
4387                      Maybe_Primitive_Operation (Overriding => True);
4388                      goto Check_Inequality;
4389                   end;
4390
4391                --  Apparent redeclarations in instances can occur when two
4392                --  formal types get the same actual type. The subprograms in
4393                --  in the instance are legal,  even if not callable from the
4394                --  outside. Calls from within are disambiguated elsewhere.
4395                --  For dispatching operations in the visible part, the usual
4396                --  rules apply, and operations with the same profile are not
4397                --  legal (B830001).
4398
4399                elsif (In_Instance_Visible_Part
4400                        and then not Is_Dispatching_Operation (E))
4401                  or else In_Instance_Not_Visible
4402                then
4403                   null;
4404
4405                --  Here we have a real error (identical profile)
4406
4407                else
4408                   Error_Msg_Sloc := Sloc (E);
4409
4410                   --  Avoid cascaded errors if the entity appears in
4411                   --  subsequent calls.
4412
4413                   Set_Scope (S, Current_Scope);
4414
4415                   Error_Msg_N ("& conflicts with declaration#", S);
4416
4417                   if Is_Generic_Instance (S)
4418                     and then not Has_Completion (E)
4419                   then
4420                      Error_Msg_N
4421                        ("\instantiation cannot provide body for it", S);
4422                   end if;
4423
4424                   return;
4425                end if;
4426
4427             else
4428                null;
4429             end if;
4430
4431             Prev_Vis := E;
4432             E := Homonym (E);
4433          end loop;
4434
4435          --  On exit, we know that S is a new entity
4436
4437          Enter_Overloaded_Entity (S);
4438          Maybe_Primitive_Operation;
4439
4440          --  If S is a derived operation for an untagged type then
4441          --  by definition it's not a dispatching operation (even
4442          --  if the parent operation was dispatching), so we don't
4443          --  call Check_Dispatching_Operation in that case.
4444
4445          if not Present (Derived_Type)
4446            or else Is_Tagged_Type (Derived_Type)
4447          then
4448             Check_Dispatching_Operation (S, Empty);
4449          end if;
4450       end if;
4451
4452       --  If this is a  user-defined equality operator that is not
4453       --  a derived subprogram, create the corresponding inequality.
4454       --  If the operation is dispatching, the expansion is done
4455       --  elsewhere,  and we do not create an explicit inequality
4456       --  operation.
4457
4458       <<Check_Inequality>>
4459          if Chars (S) = Name_Op_Eq
4460            and then Etype (S) = Standard_Boolean
4461            and then Present (Parent (S))
4462            and then not Is_Dispatching_Operation (S)
4463          then
4464             Make_Inequality_Operator (S);
4465          end if;
4466
4467    end New_Overloaded_Entity;
4468
4469    ---------------------
4470    -- Process_Formals --
4471    ---------------------
4472
4473    procedure Process_Formals
4474      (T           : List_Id;
4475       Related_Nod : Node_Id)
4476    is
4477       Param_Spec  : Node_Id;
4478       Formal      : Entity_Id;
4479       Formal_Type : Entity_Id;
4480       Default     : Node_Id;
4481       Ptype       : Entity_Id;
4482
4483       function Is_Class_Wide_Default (D : Node_Id) return Boolean;
4484       --  Check whether the default has a class-wide type. After analysis
4485       --  the default has the type of the formal, so we must also check
4486       --  explicitly for an access attribute.
4487
4488       ---------------------------
4489       -- Is_Class_Wide_Default --
4490       ---------------------------
4491
4492       function Is_Class_Wide_Default (D : Node_Id) return Boolean is
4493       begin
4494          return Is_Class_Wide_Type (Designated_Type (Etype (D)))
4495            or else (Nkind (D) =  N_Attribute_Reference
4496                       and then Attribute_Name (D) = Name_Access
4497                       and then Is_Class_Wide_Type (Etype (Prefix (D))));
4498       end Is_Class_Wide_Default;
4499
4500    --  Start of processing for Process_Formals
4501
4502    begin
4503       --  In order to prevent premature use of the formals in the same formal
4504       --  part, the Ekind is left undefined until all default expressions are
4505       --  analyzed. The Ekind is established in a separate loop at the end.
4506
4507       Param_Spec := First (T);
4508
4509       while Present (Param_Spec) loop
4510
4511          Formal := Defining_Identifier (Param_Spec);
4512          Enter_Name (Formal);
4513
4514          --  Case of ordinary parameters
4515
4516          if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
4517             Find_Type (Parameter_Type (Param_Spec));
4518             Ptype := Parameter_Type (Param_Spec);
4519
4520             if Ptype = Error then
4521                goto Continue;
4522             end if;
4523
4524             Formal_Type := Entity (Ptype);
4525
4526             if Ekind (Formal_Type) = E_Incomplete_Type
4527               or else (Is_Class_Wide_Type (Formal_Type)
4528                         and then Ekind (Root_Type (Formal_Type)) =
4529                                                          E_Incomplete_Type)
4530             then
4531                if Nkind (Parent (T)) /= N_Access_Function_Definition
4532                  and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
4533                then
4534                   Error_Msg_N ("invalid use of incomplete type", Param_Spec);
4535                end if;
4536
4537             elsif Ekind (Formal_Type) = E_Void then
4538                Error_Msg_NE ("premature use of&",
4539                  Parameter_Type (Param_Spec), Formal_Type);
4540             end if;
4541
4542          --  An access formal type
4543
4544          else
4545             Formal_Type :=
4546               Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
4547          end if;
4548
4549          Set_Etype (Formal, Formal_Type);
4550
4551          Default :=  Expression (Param_Spec);
4552
4553          if Present (Default) then
4554             if Out_Present (Param_Spec) then
4555                Error_Msg_N
4556                  ("default initialization only allowed for IN parameters",
4557                   Param_Spec);
4558             end if;
4559
4560             --  Do the special preanalysis of the expression (see section on
4561             --  "Handling of Default Expressions" in the spec of package Sem).
4562
4563             Analyze_Default_Expression (Default, Formal_Type);
4564
4565             --  Check that the designated type of an access parameter's
4566             --  default is not a class-wide type unless the parameter's
4567             --  designated type is also class-wide.
4568
4569             if Ekind (Formal_Type) = E_Anonymous_Access_Type
4570               and then Is_Class_Wide_Default (Default)
4571               and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
4572             then
4573                Error_Msg_N
4574                  ("access to class-wide expression not allowed here", Default);
4575             end if;
4576          end if;
4577
4578       <<Continue>>
4579          Next (Param_Spec);
4580       end loop;
4581
4582       --  Now set the kind (mode) of each formal
4583
4584       Param_Spec := First (T);
4585
4586       while Present (Param_Spec) loop
4587          Formal := Defining_Identifier (Param_Spec);
4588          Set_Formal_Mode (Formal);
4589
4590          if Ekind (Formal) = E_In_Parameter then
4591             Set_Default_Value (Formal, Expression (Param_Spec));
4592
4593             if Present (Expression (Param_Spec)) then
4594                Default :=  Expression (Param_Spec);
4595
4596                if Is_Scalar_Type (Etype (Default)) then
4597                   if Nkind
4598                        (Parameter_Type (Param_Spec)) /= N_Access_Definition
4599                   then
4600                      Formal_Type := Entity (Parameter_Type (Param_Spec));
4601
4602                   else
4603                      Formal_Type := Access_Definition
4604                        (Related_Nod, Parameter_Type (Param_Spec));
4605                   end if;
4606
4607                   Apply_Scalar_Range_Check (Default, Formal_Type);
4608                end if;
4609
4610             end if;
4611          end if;
4612
4613          Next (Param_Spec);
4614       end loop;
4615
4616    end Process_Formals;
4617
4618    -------------------------
4619    -- Set_Actual_Subtypes --
4620    -------------------------
4621
4622    procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
4623       Loc        : constant Source_Ptr := Sloc (N);
4624       Decl       : Node_Id;
4625       Formal     : Entity_Id;
4626       T          : Entity_Id;
4627       First_Stmt : Node_Id := Empty;
4628       AS_Needed  : Boolean;
4629
4630    begin
4631       Formal := First_Formal (Subp);
4632       while Present (Formal) loop
4633          T := Etype (Formal);
4634
4635          --  We never need an actual subtype for a constrained formal.
4636
4637          if Is_Constrained (T) then
4638             AS_Needed := False;
4639
4640          --  If we have unknown discriminants, then we do not need an
4641          --  actual subtype, or more accurately we cannot figure it out!
4642          --  Note that all class-wide types have unknown discriminants.
4643
4644          elsif Has_Unknown_Discriminants (T) then
4645             AS_Needed := False;
4646
4647          --  At this stage we have an unconstrained type that may need
4648          --  an actual subtype. For sure the actual subtype is needed
4649          --  if we have an unconstrained array type.
4650
4651          elsif Is_Array_Type (T) then
4652             AS_Needed := True;
4653
4654          --  The only other case which needs an actual subtype is an
4655          --  unconstrained record type which is an IN parameter (we
4656          --  cannot generate actual subtypes for the OUT or IN OUT case,
4657          --  since an assignment can change the discriminant values.
4658          --  However we exclude the case of initialization procedures,
4659          --  since discriminants are handled very specially in this context,
4660          --  see the section entitled "Handling of Discriminants" in Einfo.
4661          --  We also exclude the case of Discrim_SO_Functions (functions
4662          --  used in front end layout mode for size/offset values), since
4663          --  in such functions only discriminants are referenced, and not
4664          --  only are such subtypes not needed, but they cannot always
4665          --  be generated, because of order of elaboration issues.
4666
4667          elsif Is_Record_Type (T)
4668            and then Ekind (Formal) = E_In_Parameter
4669            and then Chars (Formal) /= Name_uInit
4670            and then not Is_Discrim_SO_Function (Subp)
4671          then
4672             AS_Needed := True;
4673
4674          --  All other cases do not need an actual subtype
4675
4676          else
4677             AS_Needed := False;
4678          end if;
4679
4680          --  Generate actual subtypes for unconstrained arrays and
4681          --  unconstrained discriminated records.
4682
4683          if AS_Needed then
4684             Decl := Build_Actual_Subtype (T, Formal);
4685
4686             if Nkind (N) = N_Accept_Statement then
4687                if Present (Handled_Statement_Sequence (N)) then
4688                   First_Stmt :=
4689                     First (Statements (Handled_Statement_Sequence (N)));
4690                   Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
4691                   Mark_Rewrite_Insertion (Decl);
4692                else
4693                   --  If the accept statement has no body, there will be
4694                   --  no reference to the actuals, so no need to compute
4695                   --  actual subtypes.
4696
4697                   return;
4698                end if;
4699
4700             else
4701                Prepend (Decl, Declarations (N));
4702                Mark_Rewrite_Insertion (Decl);
4703             end if;
4704
4705             Analyze (Decl);
4706
4707             --  We need to freeze manually the generated type when it is
4708             --  inserted anywhere else than in a declarative part.
4709
4710             if Present (First_Stmt) then
4711                Insert_List_Before_And_Analyze (First_Stmt,
4712                  Freeze_Entity (Defining_Identifier (Decl), Loc));
4713             end if;
4714
4715             Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
4716          end if;
4717
4718          Next_Formal (Formal);
4719       end loop;
4720    end Set_Actual_Subtypes;
4721
4722    ---------------------
4723    -- Set_Formal_Mode --
4724    ---------------------
4725
4726    procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
4727       Spec : constant Node_Id := Parent (Formal_Id);
4728
4729    begin
4730       --  Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
4731       --  since we ensure that corresponding actuals are always valid at the
4732       --  point of the call.
4733
4734       if Out_Present (Spec) then
4735
4736          if Ekind (Scope (Formal_Id)) = E_Function
4737            or else Ekind (Scope (Formal_Id)) = E_Generic_Function
4738          then
4739             Error_Msg_N ("functions can only have IN parameters", Spec);
4740             Set_Ekind (Formal_Id, E_In_Parameter);
4741
4742          elsif In_Present (Spec) then
4743             Set_Ekind (Formal_Id, E_In_Out_Parameter);
4744
4745          else
4746             Set_Ekind (Formal_Id, E_Out_Parameter);
4747             Set_Not_Source_Assigned (Formal_Id);
4748          end if;
4749
4750       else
4751          Set_Ekind (Formal_Id, E_In_Parameter);
4752       end if;
4753
4754       Set_Mechanism (Formal_Id, Default_Mechanism);
4755       Set_Formal_Validity (Formal_Id);
4756    end Set_Formal_Mode;
4757
4758    -------------------------
4759    -- Set_Formal_Validity --
4760    -------------------------
4761
4762    procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
4763    begin
4764       --  If in full validity checking mode, then we can assume that
4765       --  an IN or IN OUT parameter is valid (see Exp_Ch5.Expand_Call)
4766
4767       if not Validity_Checks_On then
4768          return;
4769
4770       elsif Ekind (Formal_Id) = E_In_Parameter
4771         and then Validity_Check_In_Params
4772       then
4773          Set_Is_Known_Valid (Formal_Id, True);
4774
4775       elsif Ekind (Formal_Id) = E_In_Out_Parameter
4776         and then Validity_Check_In_Out_Params
4777       then
4778          Set_Is_Known_Valid (Formal_Id, True);
4779       end if;
4780    end Set_Formal_Validity;
4781
4782    ------------------------
4783    -- Subtype_Conformant --
4784    ------------------------
4785
4786    function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
4787       Result : Boolean;
4788
4789    begin
4790       Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result);
4791       return Result;
4792    end Subtype_Conformant;
4793
4794    ---------------------
4795    -- Type_Conformant --
4796    ---------------------
4797
4798    function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
4799       Result : Boolean;
4800
4801    begin
4802       Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result);
4803       return Result;
4804    end Type_Conformant;
4805
4806    -------------------------------
4807    -- Valid_Operator_Definition --
4808    -------------------------------
4809
4810    procedure Valid_Operator_Definition (Designator : Entity_Id) is
4811       N    : Integer := 0;
4812       F    : Entity_Id;
4813       Id   : constant Name_Id := Chars (Designator);
4814       N_OK : Boolean;
4815
4816    begin
4817       F := First_Formal (Designator);
4818
4819       while Present (F) loop
4820          N := N + 1;
4821
4822          if Present (Default_Value (F)) then
4823             Error_Msg_N
4824               ("default values not allowed for operator parameters",
4825                Parent (F));
4826          end if;
4827
4828          Next_Formal (F);
4829       end loop;
4830
4831       --  Verify that user-defined operators have proper number of arguments
4832       --  First case of operators which can only be unary
4833
4834       if Id = Name_Op_Not
4835         or else Id = Name_Op_Abs
4836       then
4837          N_OK := (N = 1);
4838
4839       --  Case of operators which can be unary or binary
4840
4841       elsif Id = Name_Op_Add
4842         or Id = Name_Op_Subtract
4843       then
4844          N_OK := (N in 1 .. 2);
4845
4846       --  All other operators can only be binary
4847
4848       else
4849          N_OK := (N = 2);
4850       end if;
4851
4852       if not N_OK then
4853          Error_Msg_N
4854            ("incorrect number of arguments for operator", Designator);
4855       end if;
4856
4857       if Id = Name_Op_Ne
4858         and then Base_Type (Etype (Designator)) = Standard_Boolean
4859         and then not Is_Intrinsic_Subprogram (Designator)
4860       then
4861          Error_Msg_N
4862             ("explicit definition of inequality not allowed", Designator);
4863       end if;
4864    end Valid_Operator_Definition;
4865
4866 end Sem_Ch6;