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