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