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