gcc/ada/sem_disp.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ D I S P                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Debug;    use Debug;
  28 with Elists;   use Elists;
  29 with Einfo;    use Einfo;
  30 with Exp_Disp; use Exp_Disp;
  31 with Exp_Util; use Exp_Util;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Tss;  use Exp_Tss;
  34 with Errout;   use Errout;
  35 with Lib.Xref; use Lib.Xref;
  36 with Namet;    use Namet;
  37 with Nlists;   use Nlists;
  38 with Nmake;    use Nmake;
  39 with Opt;      use Opt;
  40 with Output;   use Output;
  41 with Restrict; use Restrict;
  42 with Rident;   use Rident;
  43 with Sem;      use Sem;
  44 with Sem_Aux;  use Sem_Aux;
  45 with Sem_Ch3;  use Sem_Ch3;
  46 with Sem_Ch6;  use Sem_Ch6;
  47 with Sem_Eval; use Sem_Eval;
  48 with Sem_Type; use Sem_Type;
  49 with Sem_Util; use Sem_Util;
  50 with Snames;   use Snames;
  51 with Sinfo;    use Sinfo;
  52 with Tbuild;   use Tbuild;
  53 with Uintp;    use Uintp;
  54
  55 package body Sem_Disp is
  56
  57    -----------------------
  58    -- Local Subprograms --
  59    -----------------------
  60
  61    procedure Add_Dispatching_Operation
  62      (Tagged_Type : Entity_Id;
  63       New_Op      : Entity_Id);
  64    --  Add New_Op in the list of primitive operations of Tagged_Type
  65
  66    function Check_Controlling_Type
  67      (T    : Entity_Id;
  68       Subp : Entity_Id) return Entity_Id;
  69    --  T is the tagged type of a formal parameter or the result of Subp.
  70    --  If the subprogram has a controlling parameter or result that matches
  71    --  the type, then returns the tagged type of that parameter or result
  72    --  (returning the designated tagged type in the case of an access
  73    --  parameter); otherwise returns empty.
  74
  75    function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id;
  76    --  [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching
  77    --  type of S that has the same name of S, a type-conformant profile, an
  78    --  original corresponding operation O that is a primitive of a visible
  79    --  ancestor of the dispatching type of S and O is visible at the point of
  80    --  of declaration of S. If the entity is found the Alias of S is set to the
  81    --  original corresponding operation S and its Overridden_Operation is set
  82    --  to the found entity; otherwise return Empty.
  83    --
  84    --  This routine does not search for non-hidden primitives since they are
  85    --  covered by the normal Ada 2005 rules.
  86
  87    -------------------------------
  88    -- Add_Dispatching_Operation --
  89    -------------------------------
  90
  91    procedure Add_Dispatching_Operation
  92      (Tagged_Type : Entity_Id;
  93       New_Op      : Entity_Id)
  94    is
  95       List : constant Elist_Id := Primitive_Operations (Tagged_Type);
  96
  97    begin
  98       --  The dispatching operation may already be on the list, if it is the
  99       --  wrapper for an inherited function of a null extension (see Exp_Ch3
 100       --  for the construction of function wrappers). The list of primitive
 101       --  operations must not contain duplicates.
 102
 103       Append_Unique_Elmt (New_Op, List);
 104    end Add_Dispatching_Operation;
 105
 106    ---------------------------
 107    -- Covers_Some_Interface --
 108    ---------------------------
 109
 110    function Covers_Some_Interface (Prim : Entity_Id) return Boolean is
 111       Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim);
 112       Elmt        : Elmt_Id;
 113       E           : Entity_Id;
 114
 115    begin
 116       pragma Assert (Is_Dispatching_Operation (Prim));
 117
 118       --  Although this is a dispatching primitive we must check if its
 119       --  dispatching type is available because it may be the primitive
 120       --  of a private type not defined as tagged in its partial view.
 121
 122       if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then
 123
 124          --  If the tagged type is frozen then the internal entities associated
 125          --  with interfaces are available in the list of primitives of the
 126          --  tagged type and can be used to speed up this search.
 127
 128          if Is_Frozen (Tagged_Type) then
 129             Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
 130             while Present (Elmt) loop
 131                E := Node (Elmt);
 132
 133                if Present (Interface_Alias (E))
 134                  and then Alias (E) = Prim
 135                then
 136                   return True;
 137                end if;
 138
 139                Next_Elmt (Elmt);
 140             end loop;
 141
 142          --  Otherwise we must collect all the interface primitives and check
 143          --  if the Prim will override some interface primitive.
 144
 145          else
 146             declare
 147                Ifaces_List : Elist_Id;
 148                Iface_Elmt  : Elmt_Id;
 149                Iface       : Entity_Id;
 150                Iface_Prim  : Entity_Id;
 151
 152             begin
 153                Collect_Interfaces (Tagged_Type, Ifaces_List);
 154                Iface_Elmt := First_Elmt (Ifaces_List);
 155                while Present (Iface_Elmt) loop
 156                   Iface := Node (Iface_Elmt);
 157
 158                   Elmt := First_Elmt (Primitive_Operations (Iface));
 159                   while Present (Elmt) loop
 160                      Iface_Prim := Node (Elmt);
 161
 162                      if Chars (E) = Chars (Prim)
 163                        and then Is_Interface_Conformant
 164                                   (Tagged_Type, Iface_Prim, Prim)
 165                      then
 166                         return True;
 167                      end if;
 168
 169                      Next_Elmt (Elmt);
 170                   end loop;
 171
 172                   Next_Elmt (Iface_Elmt);
 173                end loop;
 174             end;
 175          end if;
 176       end if;
 177
 178       return False;
 179    end Covers_Some_Interface;
 180
 181    -------------------------------
 182    -- Check_Controlling_Formals --
 183    -------------------------------
 184
 185    procedure Check_Controlling_Formals
 186      (Typ  : Entity_Id;
 187       Subp : Entity_Id)
 188    is
 189       Formal    : Entity_Id;
 190       Ctrl_Type : Entity_Id;
 191
 192    begin
 193       Formal := First_Formal (Subp);
 194       while Present (Formal) loop
 195          Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
 196
 197          if Present (Ctrl_Type) then
 198
 199             --  When controlling type is concurrent and declared within a
 200             --  generic or inside an instance use corresponding record type.
 201
 202             if Is_Concurrent_Type (Ctrl_Type)
 203               and then Present (Corresponding_Record_Type (Ctrl_Type))
 204             then
 205                Ctrl_Type := Corresponding_Record_Type (Ctrl_Type);
 206             end if;
 207
 208             if Ctrl_Type = Typ then
 209                Set_Is_Controlling_Formal (Formal);
 210
 211                --  Ada 2005 (AI-231): Anonymous access types that are used in
 212                --  controlling parameters exclude null because it is necessary
 213                --  to read the tag to dispatch, and null has no tag.
 214
 215                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
 216                   Set_Can_Never_Be_Null (Etype (Formal));
 217                   Set_Is_Known_Non_Null (Etype (Formal));
 218                end if;
 219
 220                --  Check that the parameter's nominal subtype statically
 221                --  matches the first subtype.
 222
 223                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
 224                   if not Subtypes_Statically_Match
 225                            (Typ, Designated_Type (Etype (Formal)))
 226                   then
 227                      Error_Msg_N
 228                        ("parameter subtype does not match controlling type",
 229                         Formal);
 230                   end if;
 231
 232                elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
 233                   Error_Msg_N
 234                     ("parameter subtype does not match controlling type",
 235                      Formal);
 236                end if;
 237
 238                if Present (Default_Value (Formal)) then
 239
 240                   --  In Ada 2005, access parameters can have defaults
 241
 242                   if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
 243                     and then Ada_Version < Ada_2005
 244                   then
 245                      Error_Msg_N
 246                        ("default not allowed for controlling access parameter",
 247                         Default_Value (Formal));
 248
 249                   elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
 250                      Error_Msg_N
 251                        ("default expression must be a tag indeterminate" &
 252                         " function call", Default_Value (Formal));
 253                   end if;
 254                end if;
 255
 256             elsif Comes_From_Source (Subp) then
 257                Error_Msg_N
 258                  ("operation can be dispatching in only one type", Subp);
 259             end if;
 260          end if;
 261
 262          Next_Formal (Formal);
 263       end loop;
 264
 265       if Ekind_In (Subp, E_Function, E_Generic_Function) then
 266          Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
 267
 268          if Present (Ctrl_Type) then
 269             if Ctrl_Type = Typ then
 270                Set_Has_Controlling_Result (Subp);
 271
 272                --  Check that result subtype statically matches first subtype
 273                --  (Ada 2005): Subp may have a controlling access result.
 274
 275                if Subtypes_Statically_Match (Typ, Etype (Subp))
 276                  or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type
 277                             and then
 278                               Subtypes_Statically_Match
 279                                 (Typ, Designated_Type (Etype (Subp))))
 280                then
 281                   null;
 282
 283                else
 284                   Error_Msg_N
 285                     ("result subtype does not match controlling type", Subp);
 286                end if;
 287
 288             elsif Comes_From_Source (Subp) then
 289                Error_Msg_N
 290                  ("operation can be dispatching in only one type", Subp);
 291             end if;
 292          end if;
 293       end if;
 294    end Check_Controlling_Formals;
 295
 296    ----------------------------
 297    -- Check_Controlling_Type --
 298    ----------------------------
 299
 300    function Check_Controlling_Type
 301      (T    : Entity_Id;
 302       Subp : Entity_Id) return Entity_Id
 303    is
 304       Tagged_Type : Entity_Id := Empty;
 305
 306    begin
 307       if Is_Tagged_Type (T) then
 308          if Is_First_Subtype (T) then
 309             Tagged_Type := T;
 310          else
 311             Tagged_Type := Base_Type (T);
 312          end if;
 313
 314       elsif Ekind (T) = E_Anonymous_Access_Type
 315         and then Is_Tagged_Type (Designated_Type (T))
 316       then
 317          if Ekind (Designated_Type (T)) /= E_Incomplete_Type then
 318             if Is_First_Subtype (Designated_Type (T)) then
 319                Tagged_Type := Designated_Type (T);
 320             else
 321                Tagged_Type := Base_Type (Designated_Type (T));
 322             end if;
 323
 324          --  Ada 2005: an incomplete type can be tagged. An operation with an
 325          --  access parameter of the type is dispatching.
 326
 327          elsif Scope (Designated_Type (T)) = Current_Scope then
 328             Tagged_Type := Designated_Type (T);
 329
 330          --  Ada 2005 (AI-50217)
 331
 332          elsif From_With_Type (Designated_Type (T))
 333            and then Present (Non_Limited_View (Designated_Type (T)))
 334          then
 335             if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then
 336                Tagged_Type := Non_Limited_View (Designated_Type (T));
 337             else
 338                Tagged_Type := Base_Type (Non_Limited_View
 339                                          (Designated_Type (T)));
 340             end if;
 341          end if;
 342       end if;
 343
 344       if No (Tagged_Type) or else Is_Class_Wide_Type (Tagged_Type) then
 345          return Empty;
 346
 347       --  The dispatching type and the primitive operation must be defined in
 348       --  the same scope, except in the case of internal operations and formal
 349       --  abstract subprograms.
 350
 351       elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp))
 352                and then (not Is_Generic_Type (Tagged_Type)
 353                           or else not Comes_From_Source (Subp)))
 354         or else
 355           (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
 356         or else
 357           (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
 358             and then
 359               Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
 360             and then
 361               Is_Abstract_Subprogram (Subp))
 362       then
 363          return Tagged_Type;
 364
 365       else
 366          return Empty;
 367       end if;
 368    end Check_Controlling_Type;
 369
 370    ----------------------------
 371    -- Check_Dispatching_Call --
 372    ----------------------------
 373
 374    procedure Check_Dispatching_Call (N : Node_Id) is
 375       Loc                    : constant Source_Ptr := Sloc (N);
 376       Actual                 : Node_Id;
 377       Formal                 : Entity_Id;
 378       Control                : Node_Id := Empty;
 379       Func                   : Entity_Id;
 380       Subp_Entity            : Entity_Id;
 381       Indeterm_Ancestor_Call : Boolean := False;
 382       Indeterm_Ctrl_Type     : Entity_Id;
 383
 384       Static_Tag : Node_Id := Empty;
 385       --  If a controlling formal has a statically tagged actual, the tag of
 386       --  this actual is to be used for any tag-indeterminate actual.
 387
 388       procedure Check_Direct_Call;
 389       --  In the case when the controlling actual is a class-wide type whose
 390       --  root type's completion is a task or protected type, the call is in
 391       --  fact direct. This routine detects the above case and modifies the
 392       --  call accordingly.
 393
 394       procedure Check_Dispatching_Context;
 395       --  If the call is tag-indeterminate and the entity being called is
 396       --  abstract, verify that the context is a call that will eventually
 397       --  provide a tag for dispatching, or has provided one already.
 398
 399       -----------------------
 400       -- Check_Direct_Call --
 401       -----------------------
 402
 403       procedure Check_Direct_Call is
 404          Typ : Entity_Id := Etype (Control);
 405
 406          function Is_User_Defined_Equality (Id : Entity_Id) return Boolean;
 407          --  Determine whether an entity denotes a user-defined equality
 408
 409          ------------------------------
 410          -- Is_User_Defined_Equality --
 411          ------------------------------
 412
 413          function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
 414          begin
 415             return
 416               Ekind (Id) = E_Function
 417                 and then Chars (Id) = Name_Op_Eq
 418                 and then Comes_From_Source (Id)
 419
 420                --  Internally generated equalities have a full type declaration
 421                --  as their parent.
 422
 423                 and then Nkind (Parent (Id)) = N_Function_Specification;
 424          end Is_User_Defined_Equality;
 425
 426       --  Start of processing for Check_Direct_Call
 427
 428       begin
 429          --  Predefined primitives do not receive wrappers since they are built
 430          --  from scratch for the corresponding record of synchronized types.
 431          --  Equality is in general predefined, but is excluded from the check
 432          --  when it is user-defined.
 433
 434          if Is_Predefined_Dispatching_Operation (Subp_Entity)
 435            and then not Is_User_Defined_Equality (Subp_Entity)
 436          then
 437             return;
 438          end if;
 439
 440          if Is_Class_Wide_Type (Typ) then
 441             Typ := Root_Type (Typ);
 442          end if;
 443
 444          if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
 445             Typ := Full_View (Typ);
 446          end if;
 447
 448          if Is_Concurrent_Type (Typ)
 449               and then
 450             Present (Corresponding_Record_Type (Typ))
 451          then
 452             Typ := Corresponding_Record_Type (Typ);
 453
 454             --  The concurrent record's list of primitives should contain a
 455             --  wrapper for the entity of the call, retrieve it.
 456
 457             declare
 458                Prim          : Entity_Id;
 459                Prim_Elmt     : Elmt_Id;
 460                Wrapper_Found : Boolean := False;
 461
 462             begin
 463                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
 464                while Present (Prim_Elmt) loop
 465                   Prim := Node (Prim_Elmt);
 466
 467                   if Is_Primitive_Wrapper (Prim)
 468                     and then Wrapped_Entity (Prim) = Subp_Entity
 469                   then
 470                      Wrapper_Found := True;
 471                      exit;
 472                   end if;
 473
 474                   Next_Elmt (Prim_Elmt);
 475                end loop;
 476
 477                --  A primitive declared between two views should have a
 478                --  corresponding wrapper.
 479
 480                pragma Assert (Wrapper_Found);
 481
 482                --  Modify the call by setting the proper entity
 483
 484                Set_Entity (Name (N), Prim);
 485             end;
 486          end if;
 487       end Check_Direct_Call;
 488
 489       -------------------------------
 490       -- Check_Dispatching_Context --
 491       -------------------------------
 492
 493       procedure Check_Dispatching_Context is
 494          Subp : constant Entity_Id := Entity (Name (N));
 495          Par  : Node_Id;
 496
 497       begin
 498          if Is_Abstract_Subprogram (Subp)
 499            and then No (Controlling_Argument (N))
 500          then
 501             if Present (Alias (Subp))
 502               and then not Is_Abstract_Subprogram (Alias (Subp))
 503               and then No (DTC_Entity (Subp))
 504             then
 505                --  Private overriding of inherited abstract operation, call is
 506                --  legal.
 507
 508                Set_Entity (Name (N), Alias (Subp));
 509                return;
 510
 511             else
 512                Par := Parent (N);
 513                while Present (Par) loop
 514                   if Nkind_In (Par, N_Function_Call,
 515                                     N_Procedure_Call_Statement,
 516                                     N_Assignment_Statement,
 517                                     N_Op_Eq,
 518                                     N_Op_Ne)
 519                     and then Is_Tagged_Type (Etype (Subp))
 520                   then
 521                      return;
 522
 523                   elsif Nkind (Par) = N_Qualified_Expression
 524                     or else Nkind (Par) = N_Unchecked_Type_Conversion
 525                   then
 526                      Par := Parent (Par);
 527
 528                   else
 529                      if Ekind (Subp) = E_Function then
 530                         Error_Msg_N
 531                           ("call to abstract function must be dispatching", N);
 532
 533                      --  This error can occur for a procedure in the case of a
 534                      --  call to an abstract formal procedure with a statically
 535                      --  tagged operand.
 536
 537                      else
 538                         Error_Msg_N
 539                           ("call to abstract procedure must be dispatching",
 540                            N);
 541                      end if;
 542
 543                      return;
 544                   end if;
 545                end loop;
 546             end if;
 547          end if;
 548       end Check_Dispatching_Context;
 549
 550    --  Start of processing for Check_Dispatching_Call
 551
 552    begin
 553       --  Find a controlling argument, if any
 554
 555       if Present (Parameter_Associations (N)) then
 556          Subp_Entity := Entity (Name (N));
 557
 558          Actual := First_Actual (N);
 559          Formal := First_Formal (Subp_Entity);
 560          while Present (Actual) loop
 561             Control := Find_Controlling_Arg (Actual);
 562             exit when Present (Control);
 563
 564             --  Check for the case where the actual is a tag-indeterminate call
 565             --  whose result type is different than the tagged type associated
 566             --  with the containing call, but is an ancestor of the type.
 567
 568             if Is_Controlling_Formal (Formal)
 569               and then Is_Tag_Indeterminate (Actual)
 570               and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
 571               and then Is_Ancestor (Etype (Actual), Etype (Formal))
 572             then
 573                Indeterm_Ancestor_Call := True;
 574                Indeterm_Ctrl_Type     := Etype (Formal);
 575
 576             --  If the formal is controlling but the actual is not, the type
 577             --  of the actual is statically known, and may be used as the
 578             --  controlling tag for some other tag-indeterminate actual.
 579
 580             elsif Is_Controlling_Formal (Formal)
 581               and then Is_Entity_Name (Actual)
 582               and then Is_Tagged_Type (Etype (Actual))
 583             then
 584                Static_Tag := Actual;
 585             end if;
 586
 587             Next_Actual (Actual);
 588             Next_Formal (Formal);
 589          end loop;
 590
 591          --  If the call doesn't have a controlling actual but does have an
 592          --  indeterminate actual that requires dispatching treatment, then an
 593          --  object is needed that will serve as the controlling argument for a
 594          --  dispatching call on the indeterminate actual. This can only occur
 595          --  in the unusual situation of a default actual given by a
 596          --  tag-indeterminate call and where the type of the call is an
 597          --  ancestor of the type associated with a containing call to an
 598          --  inherited operation (see AI-239).
 599
 600          --  Rather than create an object of the tagged type, which would be
 601          --  problematic for various reasons (default initialization,
 602          --  discriminants), the tag of the containing call's associated tagged
 603          --  type is directly used to control the dispatching.
 604
 605          if No (Control)
 606            and then Indeterm_Ancestor_Call
 607            and then No (Static_Tag)
 608          then
 609             Control :=
 610               Make_Attribute_Reference (Loc,
 611                 Prefix         => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
 612                 Attribute_Name => Name_Tag);
 613
 614             Analyze (Control);
 615          end if;
 616
 617          if Present (Control) then
 618
 619             --  Verify that no controlling arguments are statically tagged
 620
 621             if Debug_Flag_E then
 622                Write_Str ("Found Dispatching call");
 623                Write_Int (Int (N));
 624                Write_Eol;
 625             end if;
 626
 627             Actual := First_Actual (N);
 628             while Present (Actual) loop
 629                if Actual /= Control then
 630
 631                   if not Is_Controlling_Actual (Actual) then
 632                      null; -- Can be anything
 633
 634                   elsif Is_Dynamically_Tagged (Actual) then
 635                      null; -- Valid parameter
 636
 637                   elsif Is_Tag_Indeterminate (Actual) then
 638
 639                      --  The tag is inherited from the enclosing call (the node
 640                      --  we are currently analyzing). Explicitly expand the
 641                      --  actual, since the previous call to Expand (from
 642                      --  Resolve_Call) had no way of knowing about the required
 643                      --  dispatching.
 644
 645                      Propagate_Tag (Control, Actual);
 646
 647                   else
 648                      Error_Msg_N
 649                        ("controlling argument is not dynamically tagged",
 650                         Actual);
 651                      return;
 652                   end if;
 653                end if;
 654
 655                Next_Actual (Actual);
 656             end loop;
 657
 658             --  Mark call as a dispatching call
 659
 660             Set_Controlling_Argument (N, Control);
 661             Check_Restriction (No_Dispatching_Calls, N);
 662
 663             --  The dispatching call may need to be converted into a direct
 664             --  call in certain cases.
 665
 666             Check_Direct_Call;
 667
 668          --  If there is a statically tagged actual and a tag-indeterminate
 669          --  call to a function of the ancestor (such as that provided by a
 670          --  default), then treat this as a dispatching call and propagate
 671          --  the tag to the tag-indeterminate call(s).
 672
 673          elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then
 674             Control :=
 675               Make_Attribute_Reference (Loc,
 676                 Prefix         =>
 677                   New_Occurrence_Of (Etype (Static_Tag), Loc),
 678                 Attribute_Name => Name_Tag);
 679
 680             Analyze (Control);
 681
 682             Actual := First_Actual (N);
 683             Formal := First_Formal (Subp_Entity);
 684             while Present (Actual) loop
 685                if Is_Tag_Indeterminate (Actual)
 686                  and then Is_Controlling_Formal (Formal)
 687                then
 688                   Propagate_Tag (Control, Actual);
 689                end if;
 690
 691                Next_Actual (Actual);
 692                Next_Formal (Formal);
 693             end loop;
 694
 695             Check_Dispatching_Context;
 696
 697          else
 698             --  The call is not dispatching, so check that there aren't any
 699             --  tag-indeterminate abstract calls left.
 700
 701             Actual := First_Actual (N);
 702             while Present (Actual) loop
 703                if Is_Tag_Indeterminate (Actual) then
 704
 705                   --  Function call case
 706
 707                   if Nkind (Original_Node (Actual)) = N_Function_Call then
 708                      Func := Entity (Name (Original_Node (Actual)));
 709
 710                   --  If the actual is an attribute then it can't be abstract
 711                   --  (the only current case of a tag-indeterminate attribute
 712                   --  is the stream Input attribute).
 713
 714                   elsif
 715                     Nkind (Original_Node (Actual)) = N_Attribute_Reference
 716                   then
 717                      Func := Empty;
 718
 719                   --  Only other possibility is a qualified expression whose
 720                   --  constituent expression is itself a call.
 721
 722                   else
 723                      Func :=
 724                        Entity (Name
 725                          (Original_Node
 726                            (Expression (Original_Node (Actual)))));
 727                   end if;
 728
 729                   if Present (Func) and then Is_Abstract_Subprogram (Func) then
 730                      Error_Msg_N
 731                        ("call to abstract function must be dispatching", N);
 732                   end if;
 733                end if;
 734
 735                Next_Actual (Actual);
 736             end loop;
 737
 738             Check_Dispatching_Context;
 739          end if;
 740
 741       else
 742          --  If dispatching on result, the enclosing call, if any, will
 743          --  determine the controlling argument. Otherwise this is the
 744          --  primitive operation of the root type.
 745
 746          Check_Dispatching_Context;
 747       end if;
 748    end Check_Dispatching_Call;
 749
 750    ---------------------------------
 751    -- Check_Dispatching_Operation --
 752    ---------------------------------
 753
 754    procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
 755       Tagged_Type            : Entity_Id;
 756       Has_Dispatching_Parent : Boolean   := False;
 757       Body_Is_Last_Primitive : Boolean   := False;
 758       Ovr_Subp               : Entity_Id := Empty;
 759
 760    begin
 761       if not Ekind_In (Subp, E_Procedure, E_Function) then
 762          return;
 763       end if;
 764
 765       Set_Is_Dispatching_Operation (Subp, False);
 766       Tagged_Type := Find_Dispatching_Type (Subp);
 767
 768       --  Ada 2005 (AI-345): Use the corresponding record (if available).
 769       --  Required because primitives of concurrent types are be attached
 770       --  to the corresponding record (not to the concurrent type).
 771
 772       if Ada_Version >= Ada_2005
 773         and then Present (Tagged_Type)
 774         and then Is_Concurrent_Type (Tagged_Type)
 775         and then Present (Corresponding_Record_Type (Tagged_Type))
 776       then
 777          Tagged_Type := Corresponding_Record_Type (Tagged_Type);
 778       end if;
 779
 780       --  (AI-345): The task body procedure is not a primitive of the tagged
 781       --  type
 782
 783       if Present (Tagged_Type)
 784         and then Is_Concurrent_Record_Type (Tagged_Type)
 785         and then Present (Corresponding_Concurrent_Type (Tagged_Type))
 786         and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type))
 787         and then Subp = Get_Task_Body_Procedure
 788                           (Corresponding_Concurrent_Type (Tagged_Type))
 789       then
 790          return;
 791       end if;
 792
 793       --  If Subp is derived from a dispatching operation then it should
 794       --  always be treated as dispatching. In this case various checks
 795       --  below will be bypassed. Makes sure that late declarations for
 796       --  inherited private subprograms are treated as dispatching, even
 797       --  if the associated tagged type is already frozen.
 798
 799       Has_Dispatching_Parent :=
 800          Present (Alias (Subp))
 801            and then Is_Dispatching_Operation (Alias (Subp));
 802
 803       if No (Tagged_Type) then
 804
 805          --  Ada 2005 (AI-251): Check that Subp is not a primitive associated
 806          --  with an abstract interface type unless the interface acts as a
 807          --  parent type in a derivation. If the interface type is a formal
 808          --  type then the operation is not primitive and therefore legal.
 809
 810          declare
 811             E   : Entity_Id;
 812             Typ : Entity_Id;
 813
 814          begin
 815             E := First_Entity (Subp);
 816             while Present (E) loop
 817
 818                --  For an access parameter, check designated type
 819
 820                if Ekind (Etype (E)) = E_Anonymous_Access_Type then
 821                   Typ := Designated_Type (Etype (E));
 822                else
 823                   Typ := Etype (E);
 824                end if;
 825
 826                if Comes_From_Source (Subp)
 827                  and then Is_Interface (Typ)
 828                  and then not Is_Class_Wide_Type (Typ)
 829                  and then not Is_Derived_Type (Typ)
 830                  and then not Is_Generic_Type (Typ)
 831                  and then not In_Instance
 832                then
 833                   Error_Msg_N ("?declaration of& is too late!", Subp);
 834                   Error_Msg_NE -- CODEFIX??
 835                     ("\spec should appear immediately after declaration of &!",
 836                      Subp, Typ);
 837                   exit;
 838                end if;
 839
 840                Next_Entity (E);
 841             end loop;
 842
 843             --  In case of functions check also the result type
 844
 845             if Ekind (Subp) = E_Function then
 846                if Is_Access_Type (Etype (Subp)) then
 847                   Typ := Designated_Type (Etype (Subp));
 848                else
 849                   Typ := Etype (Subp);
 850                end if;
 851
 852                if not Is_Class_Wide_Type (Typ)
 853                  and then Is_Interface (Typ)
 854                  and then not Is_Derived_Type (Typ)
 855                then
 856                   Error_Msg_N ("?declaration of& is too late!", Subp);
 857                   Error_Msg_NE
 858                     ("\spec should appear immediately after declaration of &!",
 859                      Subp, Typ);
 860                end if;
 861             end if;
 862          end;
 863
 864          return;
 865
 866       --  The subprograms build internally after the freezing point (such as
 867       --  init procs, interface thunks, type support subprograms, and Offset
 868       --  to top functions for accessing interface components in variable
 869       --  size tagged types) are not primitives.
 870
 871       elsif Is_Frozen (Tagged_Type)
 872         and then not Comes_From_Source (Subp)
 873         and then not Has_Dispatching_Parent
 874       then
 875          --  Complete decoration of internally built subprograms that override
 876          --  a dispatching primitive. These entities correspond with the
 877          --  following cases:
 878
 879          --  1. Ada 2005 (AI-391): Wrapper functions built by the expander
 880          --     to override functions of nonabstract null extensions. These
 881          --     primitives were added to the list of primitives of the tagged
 882          --     type by Make_Controlling_Function_Wrappers. However, attribute
 883          --     Is_Dispatching_Operation must be set to true.
 884
 885          --  2. Ada 2005 (AI-251): Wrapper procedures of null interface
 886          --     primitives.
 887
 888          --  3. Subprograms associated with stream attributes (built by
 889          --     New_Stream_Subprogram)
 890
 891          if Present (Old_Subp)
 892            and then Present (Overridden_Operation (Subp))
 893            and then Is_Dispatching_Operation (Old_Subp)
 894          then
 895             pragma Assert
 896              ((Ekind (Subp) = E_Function
 897                 and then Is_Dispatching_Operation (Old_Subp)
 898                 and then Is_Null_Extension (Base_Type (Etype (Subp))))
 899                or else
 900                 (Ekind (Subp) = E_Procedure
 901                   and then Is_Dispatching_Operation (Old_Subp)
 902                   and then Present (Alias (Old_Subp))
 903                   and then Is_Null_Interface_Primitive
 904                              (Ultimate_Alias (Old_Subp)))
 905                or else Get_TSS_Name (Subp) = TSS_Stream_Read
 906                or else Get_TSS_Name (Subp) = TSS_Stream_Write);
 907
 908             Check_Controlling_Formals (Tagged_Type, Subp);
 909             Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
 910             Set_Is_Dispatching_Operation (Subp);
 911          end if;
 912
 913          return;
 914
 915       --  The operation may be a child unit, whose scope is the defining
 916       --  package, but which is not a primitive operation of the type.
 917
 918       elsif Is_Child_Unit (Subp) then
 919          return;
 920
 921       --  If the subprogram is not defined in a package spec, the only case
 922       --  where it can be a dispatching op is when it overrides an operation
 923       --  before the freezing point of the type.
 924
 925       elsif ((not Is_Package_Or_Generic_Package (Scope (Subp)))
 926                or else In_Package_Body (Scope (Subp)))
 927         and then not Has_Dispatching_Parent
 928       then
 929          if not Comes_From_Source (Subp)
 930            or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
 931          then
 932             null;
 933
 934          --  If the type is already frozen, the overriding is not allowed
 935          --  except when Old_Subp is not a dispatching operation (which can
 936          --  occur when Old_Subp was inherited by an untagged type). However,
 937          --  a body with no previous spec freezes the type *after* its
 938          --  declaration, and therefore is a legal overriding (unless the type
 939          --  has already been frozen). Only the first such body is legal.
 940
 941          elsif Present (Old_Subp)
 942            and then Is_Dispatching_Operation (Old_Subp)
 943          then
 944             if Comes_From_Source (Subp)
 945               and then
 946                 (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
 947                   or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub)
 948             then
 949                declare
 950                   Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
 951                   Decl_Item : Node_Id;
 952
 953                begin
 954                   --  ??? The checks here for whether the type has been
 955                   --  frozen prior to the new body are not complete. It's
 956                   --  not simple to check frozenness at this point since
 957                   --  the body has already caused the type to be prematurely
 958                   --  frozen in Analyze_Declarations, but we're forced to
 959                   --  recheck this here because of the odd rule interpretation
 960                   --  that allows the overriding if the type wasn't frozen
 961                   --  prior to the body. The freezing action should probably
 962                   --  be delayed until after the spec is seen, but that's
 963                   --  a tricky change to the delicate freezing code.
 964
 965                   --  Look at each declaration following the type up until the
 966                   --  new subprogram body. If any of the declarations is a body
 967                   --  then the type has been frozen already so the overriding
 968                   --  primitive is illegal.
 969
 970                   Decl_Item := Next (Parent (Tagged_Type));
 971                   while Present (Decl_Item)
 972                     and then (Decl_Item /= Subp_Body)
 973                   loop
 974                      if Comes_From_Source (Decl_Item)
 975                        and then (Nkind (Decl_Item) in N_Proper_Body
 976                                   or else Nkind (Decl_Item) in N_Body_Stub)
 977                      then
 978                         Error_Msg_N ("overriding of& is too late!", Subp);
 979                         Error_Msg_N
 980                           ("\spec should appear immediately after the type!",
 981                            Subp);
 982                         exit;
 983                      end if;
 984
 985                      Next (Decl_Item);
 986                   end loop;
 987
 988                   --  If the subprogram doesn't follow in the list of
 989                   --  declarations including the type then the type has
 990                   --  definitely been frozen already and the body is illegal.
 991
 992                   if No (Decl_Item) then
 993                      Error_Msg_N ("overriding of& is too late!", Subp);
 994                      Error_Msg_N
 995                        ("\spec should appear immediately after the type!",
 996                         Subp);
 997
 998                   elsif Is_Frozen (Subp) then
 999
1000                      --  The subprogram body declares a primitive operation.
1001                      --  if the subprogram is already frozen, we must update
1002                      --  its dispatching information explicitly here. The
1003                      --  information is taken from the overridden subprogram.
1004                      --  We must also generate a cross-reference entry because
1005                      --  references to other primitives were already created
1006                      --  when type was frozen.
1007
1008                      Body_Is_Last_Primitive := True;
1009
1010                      if Present (DTC_Entity (Old_Subp)) then
1011                         Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
1012                         Set_DT_Position (Subp, DT_Position (Old_Subp));
1013
1014                         if not Restriction_Active (No_Dispatching_Calls) then
1015                            if Building_Static_DT (Tagged_Type) then
1016
1017                               --  If the static dispatch table has not been
1018                               --  built then there is nothing else to do now;
1019                               --  otherwise we notify that we cannot build the
1020                               --  static dispatch table.
1021
1022                               if Has_Dispatch_Table (Tagged_Type) then
1023                                  Error_Msg_N
1024                                    ("overriding of& is too late for building" &
1025                                     " static dispatch tables!", Subp);
1026                                  Error_Msg_N
1027                                    ("\spec should appear immediately after" &
1028                                     " the type!", Subp);
1029                               end if;
1030
1031                            else
1032                               Insert_Actions_After (Subp_Body,
1033                                 Register_Primitive (Sloc (Subp_Body),
1034                                 Prim    => Subp));
1035                            end if;
1036
1037                            --  Indicate that this is an overriding operation,
1038                            --  and replace the overriden entry in the list of
1039                            --  primitive operations, which is used for xref
1040                            --  generation subsequently.
1041
1042                            Generate_Reference (Tagged_Type, Subp, 'P', False);
1043                            Override_Dispatching_Operation
1044                              (Tagged_Type, Old_Subp, Subp);
1045                         end if;
1046                      end if;
1047                   end if;
1048                end;
1049
1050             else
1051                Error_Msg_N ("overriding of& is too late!", Subp);
1052                Error_Msg_N
1053                  ("\subprogram spec should appear immediately after the type!",
1054                   Subp);
1055             end if;
1056
1057          --  If the type is not frozen yet and we are not in the overriding
1058          --  case it looks suspiciously like an attempt to define a primitive
1059          --  operation, which requires the declaration to be in a package spec
1060          --  (3.2.3(6)). Only report cases where the type and subprogram are
1061          --  in the same declaration list (by checking the enclosing parent
1062          --  declarations), to avoid spurious warnings on subprograms in
1063          --  instance bodies when the type is declared in the instance spec but
1064          --  hasn't been frozen by the instance body.
1065
1066          elsif not Is_Frozen (Tagged_Type)
1067            and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp)))
1068          then
1069             Error_Msg_N
1070               ("?not dispatching (must be defined in a package spec)", Subp);
1071             return;
1072
1073          --  When the type is frozen, it is legitimate to define a new
1074          --  non-primitive operation.
1075
1076          else
1077             return;
1078          end if;
1079
1080       --  Now, we are sure that the scope is a package spec. If the subprogram
1081       --  is declared after the freezing point of the type that's an error
1082
1083       elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
1084          Error_Msg_N ("this primitive operation is declared too late", Subp);
1085          Error_Msg_NE
1086            ("?no primitive operations for& after this line",
1087             Freeze_Node (Tagged_Type),
1088             Tagged_Type);
1089          return;
1090       end if;
1091
1092       Check_Controlling_Formals (Tagged_Type, Subp);
1093
1094       Ovr_Subp := Old_Subp;
1095
1096       --  [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
1097       --  overridden by Subp
1098
1099       if No (Ovr_Subp)
1100         and then Ada_Version >= Ada_2012
1101       then
1102          Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp);
1103       end if;
1104
1105       --  Now it should be a correct primitive operation, put it in the list
1106
1107       if Present (Ovr_Subp) then
1108
1109          --  If the type has interfaces we complete this check after we set
1110          --  attribute Is_Dispatching_Operation.
1111
1112          Check_Subtype_Conformant (Subp, Ovr_Subp);
1113
1114          if (Chars (Subp) = Name_Initialize
1115            or else Chars (Subp) = Name_Adjust
1116            or else Chars (Subp) = Name_Finalize)
1117            and then Is_Controlled (Tagged_Type)
1118            and then not Is_Visibly_Controlled (Tagged_Type)
1119          then
1120             Set_Overridden_Operation (Subp, Empty);
1121
1122             --  If the subprogram specification carries an overriding
1123             --  indicator, no need for the warning: it is either redundant,
1124             --  or else an error will be reported.
1125
1126             if Nkind (Parent (Subp)) = N_Procedure_Specification
1127               and then
1128                 (Must_Override (Parent (Subp))
1129                   or else Must_Not_Override (Parent (Subp)))
1130             then
1131                null;
1132
1133             --  Here we need the warning
1134
1135             else
1136                Error_Msg_NE
1137                  ("operation does not override inherited&?", Subp, Subp);
1138             end if;
1139
1140          else
1141             Override_Dispatching_Operation (Tagged_Type, Ovr_Subp, Subp);
1142
1143             --  Ada 2005 (AI-251): In case of late overriding of a primitive
1144             --  that covers abstract interface subprograms we must register it
1145             --  in all the secondary dispatch tables associated with abstract
1146             --  interfaces. We do this now only if not building static tables.
1147             --  Otherwise the patch code is emitted after those tables are
1148             --  built, to prevent access_before_elaboration in gigi.
1149
1150             if Body_Is_Last_Primitive then
1151                declare
1152                   Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
1153                   Elmt      : Elmt_Id;
1154                   Prim      : Node_Id;
1155
1156                begin
1157                   Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1158                   while Present (Elmt) loop
1159                      Prim := Node (Elmt);
1160
1161                      if Present (Alias (Prim))
1162                        and then Present (Interface_Alias (Prim))
1163                        and then Alias (Prim) = Subp
1164                        and then not Building_Static_DT (Tagged_Type)
1165                      then
1166                         Insert_Actions_After (Subp_Body,
1167                           Register_Primitive (Sloc (Subp_Body), Prim => Prim));
1168                      end if;
1169
1170                      Next_Elmt (Elmt);
1171                   end loop;
1172
1173                   --  Redisplay the contents of the updated dispatch table
1174
1175                   if Debug_Flag_ZZ then
1176                      Write_Str ("Late overriding: ");
1177                      Write_DT (Tagged_Type);
1178                   end if;
1179                end;
1180             end if;
1181          end if;
1182
1183       --  If the tagged type is a concurrent type then we must be compiling
1184       --  with no code generation (we are either compiling a generic unit or
1185       --  compiling under -gnatc mode) because we have previously tested that
1186       --  no serious errors has been reported. In this case we do not add the
1187       --  primitive to the list of primitives of Tagged_Type but we leave the
1188       --  primitive decorated as a dispatching operation to be able to analyze
1189       --  and report errors associated with the Object.Operation notation.
1190
1191       elsif Is_Concurrent_Type (Tagged_Type) then
1192          pragma Assert (not Expander_Active);
1193          null;
1194
1195       --  If no old subprogram, then we add this as a dispatching operation,
1196       --  but we avoid doing this if an error was posted, to prevent annoying
1197       --  cascaded errors.
1198
1199       elsif not Error_Posted (Subp) then
1200          Add_Dispatching_Operation (Tagged_Type, Subp);
1201       end if;
1202
1203       Set_Is_Dispatching_Operation (Subp, True);
1204
1205       --  Ada 2005 (AI-251): If the type implements interfaces we must check
1206       --  subtype conformance against all the interfaces covered by this
1207       --  primitive.
1208
1209       if Present (Ovr_Subp)
1210         and then Has_Interfaces (Tagged_Type)
1211       then
1212          declare
1213             Ifaces_List     : Elist_Id;
1214             Iface_Elmt      : Elmt_Id;
1215             Iface_Prim_Elmt : Elmt_Id;
1216             Iface_Prim      : Entity_Id;
1217             Ret_Typ         : Entity_Id;
1218
1219          begin
1220             Collect_Interfaces (Tagged_Type, Ifaces_List);
1221
1222             Iface_Elmt := First_Elmt (Ifaces_List);
1223             while Present (Iface_Elmt) loop
1224                if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then
1225                   Iface_Prim_Elmt :=
1226                     First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
1227                   while Present (Iface_Prim_Elmt) loop
1228                      Iface_Prim := Node (Iface_Prim_Elmt);
1229
1230                      if Is_Interface_Conformant
1231                           (Tagged_Type, Iface_Prim, Subp)
1232                      then
1233                         --  Handle procedures, functions whose return type
1234                         --  matches, or functions not returning interfaces
1235
1236                         if Ekind (Subp) = E_Procedure
1237                           or else Etype (Iface_Prim) = Etype (Subp)
1238                           or else not Is_Interface (Etype (Iface_Prim))
1239                         then
1240                            Check_Subtype_Conformant
1241                              (New_Id  => Subp,
1242                               Old_Id  => Iface_Prim,
1243                               Err_Loc => Subp,
1244                               Skip_Controlling_Formals => True);
1245
1246                         --  Handle functions returning interfaces
1247
1248                         elsif Implements_Interface
1249                                 (Etype (Subp), Etype (Iface_Prim))
1250                         then
1251                            --  Temporarily force both entities to return the
1252                            --  same type. Required because Subtype_Conformant
1253                            --  does not handle this case.
1254
1255                            Ret_Typ := Etype (Iface_Prim);
1256                            Set_Etype (Iface_Prim, Etype (Subp));
1257
1258                            Check_Subtype_Conformant
1259                              (New_Id  => Subp,
1260                               Old_Id  => Iface_Prim,
1261                               Err_Loc => Subp,
1262                               Skip_Controlling_Formals => True);
1263
1264                            Set_Etype (Iface_Prim, Ret_Typ);
1265                         end if;
1266                      end if;
1267
1268                      Next_Elmt (Iface_Prim_Elmt);
1269                   end loop;
1270                end if;
1271
1272                Next_Elmt (Iface_Elmt);
1273             end loop;
1274          end;
1275       end if;
1276
1277       if not Body_Is_Last_Primitive then
1278          Set_DT_Position (Subp, No_Uint);
1279
1280       elsif Has_Controlled_Component (Tagged_Type)
1281         and then
1282          (Chars (Subp) = Name_Initialize
1283             or else
1284           Chars (Subp) = Name_Adjust
1285             or else
1286           Chars (Subp) = Name_Finalize)
1287       then
1288          declare
1289             F_Node   : constant Node_Id := Freeze_Node (Tagged_Type);
1290             Decl     : Node_Id;
1291             Old_P    : Entity_Id;
1292             Old_Bod  : Node_Id;
1293             Old_Spec : Entity_Id;
1294
1295             C_Names : constant array (1 .. 3) of Name_Id :=
1296                         (Name_Initialize,
1297                          Name_Adjust,
1298                          Name_Finalize);
1299
1300             D_Names : constant array (1 .. 3) of TSS_Name_Type :=
1301                         (TSS_Deep_Initialize,
1302                          TSS_Deep_Adjust,
1303                          TSS_Deep_Finalize);
1304
1305          begin
1306             --  Remove previous controlled function which was constructed and
1307             --  analyzed when the type was frozen. This requires removing the
1308             --  body of the redefined primitive, as well as its specification
1309             --  if needed (there is no spec created for Deep_Initialize, see
1310             --  exp_ch3.adb). We must also dismantle the exception information
1311             --  that may have been generated for it when front end zero-cost
1312             --  tables are enabled.
1313
1314             for J in D_Names'Range loop
1315                Old_P := TSS (Tagged_Type, D_Names (J));
1316
1317                if Present (Old_P)
1318                 and then Chars (Subp) = C_Names (J)
1319                then
1320                   Old_Bod := Unit_Declaration_Node (Old_P);
1321                   Remove (Old_Bod);
1322                   Set_Is_Eliminated (Old_P);
1323                   Set_Scope (Old_P,  Scope (Current_Scope));
1324
1325                   if Nkind (Old_Bod) = N_Subprogram_Body
1326                     and then Present (Corresponding_Spec (Old_Bod))
1327                   then
1328                      Old_Spec := Corresponding_Spec (Old_Bod);
1329                      Set_Has_Completion             (Old_Spec, False);
1330                   end if;
1331                end if;
1332             end loop;
1333
1334             Build_Late_Proc (Tagged_Type, Chars (Subp));
1335
1336             --  The new operation is added to the actions of the freeze node
1337             --  for the type, but this node has already been analyzed, so we
1338             --  must retrieve and analyze explicitly the new body.
1339
1340             if Present (F_Node)
1341               and then Present (Actions (F_Node))
1342             then
1343                Decl := Last (Actions (F_Node));
1344                Analyze (Decl);
1345             end if;
1346          end;
1347       end if;
1348    end Check_Dispatching_Operation;
1349
1350    ------------------------------------------
1351    -- Check_Operation_From_Incomplete_Type --
1352    ------------------------------------------
1353
1354    procedure Check_Operation_From_Incomplete_Type
1355      (Subp : Entity_Id;
1356       Typ  : Entity_Id)
1357    is
1358       Full       : constant Entity_Id := Full_View (Typ);
1359       Parent_Typ : constant Entity_Id := Etype (Full);
1360       Old_Prim   : constant Elist_Id  := Primitive_Operations (Parent_Typ);
1361       New_Prim   : constant Elist_Id  := Primitive_Operations (Full);
1362       Op1, Op2   : Elmt_Id;
1363       Prev       : Elmt_Id := No_Elmt;
1364
1365       function Derives_From (Proc : Entity_Id) return Boolean;
1366       --  Check that Subp has the signature of an operation derived from Proc.
1367       --  Subp has an access parameter that designates Typ.
1368
1369       ------------------
1370       -- Derives_From --
1371       ------------------
1372
1373       function Derives_From (Proc : Entity_Id) return Boolean is
1374          F1, F2 : Entity_Id;
1375
1376       begin
1377          if Chars (Proc) /= Chars (Subp) then
1378             return False;
1379          end if;
1380
1381          F1 := First_Formal (Proc);
1382          F2 := First_Formal (Subp);
1383          while Present (F1) and then Present (F2) loop
1384             if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
1385                if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
1386                   return False;
1387                elsif Designated_Type (Etype (F1)) = Parent_Typ
1388                  and then Designated_Type (Etype (F2)) /= Full
1389                then
1390                   return False;
1391                end if;
1392
1393             elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
1394                return False;
1395
1396             elsif Etype (F1) /= Etype (F2) then
1397                return False;
1398             end if;
1399
1400             Next_Formal (F1);
1401             Next_Formal (F2);
1402          end loop;
1403
1404          return No (F1) and then No (F2);
1405       end Derives_From;
1406
1407    --  Start of processing for Check_Operation_From_Incomplete_Type
1408
1409    begin
1410       --  The operation may override an inherited one, or may be a new one
1411       --  altogether. The inherited operation will have been hidden by the
1412       --  current one at the point of the type derivation, so it does not
1413       --  appear in the list of primitive operations of the type. We have to
1414       --  find the proper place of insertion in the list of primitive opera-
1415       --  tions by iterating over the list for the parent type.
1416
1417       Op1 := First_Elmt (Old_Prim);
1418       Op2 := First_Elmt (New_Prim);
1419       while Present (Op1) and then Present (Op2) loop
1420          if Derives_From (Node (Op1)) then
1421             if No (Prev) then
1422
1423                --  Avoid adding it to the list of primitives if already there!
1424
1425                if Node (Op2) /= Subp then
1426                   Prepend_Elmt (Subp, New_Prim);
1427                end if;
1428
1429             else
1430                Insert_Elmt_After (Subp, Prev);
1431             end if;
1432
1433             return;
1434          end if;
1435
1436          Prev := Op2;
1437          Next_Elmt (Op1);
1438          Next_Elmt (Op2);
1439       end loop;
1440
1441       --  Operation is a new primitive
1442
1443       Append_Elmt (Subp, New_Prim);
1444    end Check_Operation_From_Incomplete_Type;
1445
1446    ---------------------------------------
1447    -- Check_Operation_From_Private_View --
1448    ---------------------------------------
1449
1450    procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
1451       Tagged_Type : Entity_Id;
1452
1453    begin
1454       if Is_Dispatching_Operation (Alias (Subp)) then
1455          Set_Scope (Subp, Current_Scope);
1456          Tagged_Type := Find_Dispatching_Type (Subp);
1457
1458          --  Add Old_Subp to primitive operations if not already present
1459
1460          if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
1461             Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
1462
1463             --  If Old_Subp isn't already marked as dispatching then
1464             --  this is the case of an operation of an untagged private
1465             --  type fulfilled by a tagged type that overrides an
1466             --  inherited dispatching operation, so we set the necessary
1467             --  dispatching attributes here.
1468
1469             if not Is_Dispatching_Operation (Old_Subp) then
1470
1471                --  If the untagged type has no discriminants, and the full
1472                --  view is constrained, there will be a spurious mismatch
1473                --  of subtypes on the controlling arguments, because the tagged
1474                --  type is the internal base type introduced in the derivation.
1475                --  Use the original type to verify conformance, rather than the
1476                --  base type.
1477
1478                if not Comes_From_Source (Tagged_Type)
1479                  and then Has_Discriminants (Tagged_Type)
1480                then
1481                   declare
1482                      Formal : Entity_Id;
1483
1484                   begin
1485                      Formal := First_Formal (Old_Subp);
1486                      while Present (Formal) loop
1487                         if Tagged_Type = Base_Type (Etype (Formal)) then
1488                            Tagged_Type := Etype (Formal);
1489                         end if;
1490
1491                         Next_Formal (Formal);
1492                      end loop;
1493                   end;
1494
1495                   if Tagged_Type = Base_Type (Etype (Old_Subp)) then
1496                      Tagged_Type := Etype (Old_Subp);
1497                   end if;
1498                end if;
1499
1500                Check_Controlling_Formals (Tagged_Type, Old_Subp);
1501                Set_Is_Dispatching_Operation (Old_Subp, True);
1502                Set_DT_Position (Old_Subp, No_Uint);
1503             end if;
1504
1505             --  If the old subprogram is an explicit renaming of some other
1506             --  entity, it is not overridden by the inherited subprogram.
1507             --  Otherwise, update its alias and other attributes.
1508
1509             if Present (Alias (Old_Subp))
1510               and then Nkind (Unit_Declaration_Node (Old_Subp)) /=
1511                                         N_Subprogram_Renaming_Declaration
1512             then
1513                Set_Alias (Old_Subp, Alias (Subp));
1514
1515                --  The derived subprogram should inherit the abstractness
1516                --  of the parent subprogram (except in the case of a function
1517                --  returning the type). This sets the abstractness properly
1518                --  for cases where a private extension may have inherited
1519                --  an abstract operation, but the full type is derived from
1520                --  a descendant type and inherits a nonabstract version.
1521
1522                if Etype (Subp) /= Tagged_Type then
1523                   Set_Is_Abstract_Subprogram
1524                     (Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
1525                end if;
1526             end if;
1527          end if;
1528       end if;
1529    end Check_Operation_From_Private_View;
1530
1531    --------------------------
1532    -- Find_Controlling_Arg --
1533    --------------------------
1534
1535    function Find_Controlling_Arg (N : Node_Id) return Node_Id is
1536       Orig_Node : constant Node_Id := Original_Node (N);
1537       Typ       : Entity_Id;
1538
1539    begin
1540       if Nkind (Orig_Node) = N_Qualified_Expression then
1541          return Find_Controlling_Arg (Expression (Orig_Node));
1542       end if;
1543
1544       --  Dispatching on result case. If expansion is disabled, the node still
1545       --  has the structure of a function call. However, if the function name
1546       --  is an operator and the call was given in infix form, the original
1547       --  node has no controlling result and we must examine the current node.
1548
1549       if Nkind (N) = N_Function_Call
1550         and then Present (Controlling_Argument (N))
1551         and then Has_Controlling_Result (Entity (Name (N)))
1552       then
1553          return Controlling_Argument (N);
1554
1555       --  If expansion is enabled, the call may have been transformed into
1556       --  an indirect call, and we need to recover the original node.
1557
1558       elsif Nkind (Orig_Node) = N_Function_Call
1559         and then Present (Controlling_Argument (Orig_Node))
1560         and then Has_Controlling_Result (Entity (Name (Orig_Node)))
1561       then
1562          return Controlling_Argument (Orig_Node);
1563
1564       --  Normal case
1565
1566       elsif Is_Controlling_Actual (N)
1567         or else
1568          (Nkind (Parent (N)) = N_Qualified_Expression
1569            and then Is_Controlling_Actual (Parent (N)))
1570       then
1571          Typ := Etype (N);
1572
1573          if Is_Access_Type (Typ) then
1574
1575             --  In the case of an Access attribute, use the type of the prefix,
1576             --  since in the case of an actual for an access parameter, the
1577             --  attribute's type may be of a specific designated type, even
1578             --  though the prefix type is class-wide.
1579
1580             if Nkind (N) = N_Attribute_Reference then
1581                Typ := Etype (Prefix (N));
1582
1583             --  An allocator is dispatching if the type of qualified expression
1584             --  is class_wide, in which case this is the controlling type.
1585
1586             elsif Nkind (Orig_Node) = N_Allocator
1587                and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
1588             then
1589                Typ := Etype (Expression (Orig_Node));
1590             else
1591                Typ := Designated_Type (Typ);
1592             end if;
1593          end if;
1594
1595          if Is_Class_Wide_Type (Typ)
1596            or else
1597              (Nkind (Parent (N)) = N_Qualified_Expression
1598                and then Is_Access_Type (Etype (N))
1599                and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
1600          then
1601             return N;
1602          end if;
1603       end if;
1604
1605       return Empty;
1606    end Find_Controlling_Arg;
1607
1608    ---------------------------
1609    -- Find_Dispatching_Type --
1610    ---------------------------
1611
1612    function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
1613       A_Formal  : Entity_Id;
1614       Formal    : Entity_Id;
1615       Ctrl_Type : Entity_Id;
1616
1617    begin
1618       if Present (DTC_Entity (Subp)) then
1619          return Scope (DTC_Entity (Subp));
1620
1621       --  For subprograms internally generated by derivations of tagged types
1622       --  use the alias subprogram as a reference to locate the dispatching
1623       --  type of Subp.
1624
1625       elsif not Comes_From_Source (Subp)
1626         and then Present (Alias (Subp))
1627         and then Is_Dispatching_Operation (Alias (Subp))
1628       then
1629          if Ekind (Alias (Subp)) = E_Function
1630            and then Has_Controlling_Result (Alias (Subp))
1631          then
1632             return Check_Controlling_Type (Etype (Subp), Subp);
1633
1634          else
1635             Formal   := First_Formal (Subp);
1636             A_Formal := First_Formal (Alias (Subp));
1637             while Present (A_Formal) loop
1638                if Is_Controlling_Formal (A_Formal) then
1639                   return Check_Controlling_Type (Etype (Formal), Subp);
1640                end if;
1641
1642                Next_Formal (Formal);
1643                Next_Formal (A_Formal);
1644             end loop;
1645
1646             pragma Assert (False);
1647             return Empty;
1648          end if;
1649
1650       --  General case
1651
1652       else
1653          Formal := First_Formal (Subp);
1654          while Present (Formal) loop
1655             Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
1656
1657             if Present (Ctrl_Type) then
1658                return Ctrl_Type;
1659             end if;
1660
1661             Next_Formal (Formal);
1662          end loop;
1663
1664          --  The subprogram may also be dispatching on result
1665
1666          if Present (Etype (Subp)) then
1667             return Check_Controlling_Type (Etype (Subp), Subp);
1668          end if;
1669       end if;
1670
1671       pragma Assert (not Is_Dispatching_Operation (Subp));
1672       return Empty;
1673    end Find_Dispatching_Type;
1674
1675    --------------------------------------
1676    -- Find_Hidden_Overridden_Primitive --
1677    --------------------------------------
1678
1679    function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id
1680    is
1681       Tag_Typ   : constant Entity_Id := Find_Dispatching_Type (S);
1682       Elmt      : Elmt_Id;
1683       Orig_Prim : Entity_Id;
1684       Prim      : Entity_Id;
1685       Vis_List  : Elist_Id;
1686
1687    begin
1688       --  This Ada 2012 rule is valid only for type extensions or private
1689       --  extensions.
1690
1691       if No (Tag_Typ)
1692         or else not Is_Record_Type (Tag_Typ)
1693         or else Etype (Tag_Typ) = Tag_Typ
1694       then
1695          return Empty;
1696       end if;
1697
1698       --  Collect the list of visible ancestor of the tagged type
1699
1700       Vis_List := Visible_Ancestors (Tag_Typ);
1701
1702       Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
1703       while Present (Elmt) loop
1704          Prim := Node (Elmt);
1705
1706          --  Find an inherited hidden dispatching primitive with the name of S
1707          --  and a type-conformant profile.
1708
1709          if Present (Alias (Prim))
1710            and then Is_Hidden (Alias (Prim))
1711            and then Find_Dispatching_Type (Alias (Prim)) /= Tag_Typ
1712            and then Primitive_Names_Match (S, Prim)
1713            and then Type_Conformant (S, Prim)
1714          then
1715             declare
1716                Vis_Ancestor : Elmt_Id;
1717                Elmt         : Elmt_Id;
1718
1719             begin
1720                --  The original corresponding operation of Prim must be an
1721                --  operation of a visible ancestor of the dispatching type
1722                --  S, and the original corresponding operation of S2 must
1723                --  be visible.
1724
1725                Orig_Prim := Original_Corresponding_Operation (Prim);
1726
1727                if Orig_Prim /= Prim
1728                  and then Is_Immediately_Visible (Orig_Prim)
1729                then
1730                   Vis_Ancestor := First_Elmt (Vis_List);
1731                   while Present (Vis_Ancestor) loop
1732                      Elmt :=
1733                        First_Elmt (Primitive_Operations (Node (Vis_Ancestor)));
1734                      while Present (Elmt) loop
1735                         if Node (Elmt) = Orig_Prim then
1736                            Set_Overridden_Operation (S, Prim);
1737                            Set_Alias (Prim, Orig_Prim);
1738                            return Prim;
1739                         end if;
1740
1741                         Next_Elmt (Elmt);
1742                      end loop;
1743
1744                      Next_Elmt (Vis_Ancestor);
1745                   end loop;
1746                end if;
1747             end;
1748          end if;
1749
1750          Next_Elmt (Elmt);
1751       end loop;
1752
1753       return Empty;
1754    end Find_Hidden_Overridden_Primitive;
1755
1756    ---------------------------------------
1757    -- Find_Primitive_Covering_Interface --
1758    ---------------------------------------
1759
1760    function Find_Primitive_Covering_Interface
1761      (Tagged_Type : Entity_Id;
1762       Iface_Prim  : Entity_Id) return Entity_Id
1763    is
1764       E  : Entity_Id;
1765       El : Elmt_Id;
1766
1767    begin
1768       pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
1769         or else (Present (Alias (Iface_Prim))
1770                   and then
1771                     Is_Interface
1772                       (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
1773
1774       --  Search in the homonym chain. Done to speed up locating visible
1775       --  entities and required to catch primitives associated with the partial
1776       --  view of private types when processing the corresponding full view.
1777
1778       E := Current_Entity (Iface_Prim);
1779       while Present (E) loop
1780          if Is_Subprogram (E)
1781            and then Is_Dispatching_Operation (E)
1782            and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E)
1783          then
1784             return E;
1785          end if;
1786
1787          E := Homonym (E);
1788       end loop;
1789
1790       --  Search in the list of primitives of the type. Required to locate the
1791       --  covering primitive if the covering primitive is not visible (for
1792       --  example, non-visible inherited primitive of private type).
1793
1794       El := First_Elmt (Primitive_Operations (Tagged_Type));
1795       while Present (El) loop
1796          E := Node (El);
1797
1798          --  Keep separate the management of internal entities that link
1799          --  primitives with interface primitives from tagged type primitives.
1800
1801          if No (Interface_Alias (E)) then
1802             if Present (Alias (E)) then
1803
1804                --  This interface primitive has not been covered yet
1805
1806                if Alias (E) = Iface_Prim then
1807                   return E;
1808
1809                --  The covering primitive was inherited
1810
1811                elsif Overridden_Operation (Ultimate_Alias (E))
1812                        = Iface_Prim
1813                then
1814                   return E;
1815                end if;
1816             end if;
1817
1818             --  Check if E covers the interface primitive (includes case in
1819             --  which E is an inherited private primitive).
1820
1821             if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then
1822                return E;
1823             end if;
1824
1825          --  Use the internal entity that links the interface primitive with
1826          --  the covering primitive to locate the entity.
1827
1828          elsif Interface_Alias (E) = Iface_Prim then
1829             return Alias (E);
1830          end if;
1831
1832          Next_Elmt (El);
1833       end loop;
1834
1835       --  Not found
1836
1837       return Empty;
1838    end Find_Primitive_Covering_Interface;
1839
1840    ---------------------------
1841    -- Inherited_Subprograms --
1842    ---------------------------
1843
1844    function Inherited_Subprograms (S : Entity_Id) return Subprogram_List is
1845       Result : Subprogram_List (1 .. 6000);
1846       --  6000 here is intended to be infinity. We could use an expandable
1847       --  table, but it would be awfully heavy, and there is no way that we
1848       --  could reasonably exceed this value.
1849
1850       N : Int := 0;
1851       --  Number of entries in Result
1852
1853       Parent_Op : Entity_Id;
1854       --  Traverses the Overridden_Operation chain
1855
1856       procedure Store_IS (E : Entity_Id);
1857       --  Stores E in Result if not already stored
1858
1859       --------------
1860       -- Store_IS --
1861       --------------
1862
1863       procedure Store_IS (E : Entity_Id) is
1864       begin
1865          for J in 1 .. N loop
1866             if E = Result (J) then
1867                return;
1868             end if;
1869          end loop;
1870
1871          N := N + 1;
1872          Result (N) := E;
1873       end Store_IS;
1874
1875    --  Start of processing for Inherited_Subprograms
1876
1877    begin
1878       if Present (S) and then Is_Dispatching_Operation (S) then
1879
1880          --  Deal with direct inheritance
1881
1882          Parent_Op := S;
1883          loop
1884             Parent_Op := Overridden_Operation (Parent_Op);
1885             exit when No (Parent_Op);
1886
1887             if Is_Subprogram (Parent_Op)
1888               or else Is_Generic_Subprogram (Parent_Op)
1889             then
1890                Store_IS (Parent_Op);
1891             end if;
1892          end loop;
1893
1894          --  Now deal with interfaces
1895
1896          declare
1897             Tag_Typ : Entity_Id;
1898             Prim    : Entity_Id;
1899             Elmt    : Elmt_Id;
1900
1901          begin
1902             Tag_Typ := Find_Dispatching_Type (S);
1903
1904             if Is_Concurrent_Type (Tag_Typ) then
1905                Tag_Typ := Corresponding_Record_Type (Tag_Typ);
1906             end if;
1907
1908             --  Search primitive operations of dispatching type
1909
1910             if Present (Tag_Typ)
1911               and then Present (Primitive_Operations (Tag_Typ))
1912             then
1913                Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
1914                while Present (Elmt) loop
1915                   Prim := Node (Elmt);
1916
1917                   --  The following test eliminates some odd cases in which
1918                   --  Ekind (Prim) is Void, to be investigated further ???
1919
1920                   if not (Is_Subprogram (Prim)
1921                             or else
1922                           Is_Generic_Subprogram (Prim))
1923                   then
1924                      null;
1925
1926                      --  For [generic] subprogram, look at interface alias
1927
1928                   elsif Present (Interface_Alias (Prim))
1929                     and then Alias (Prim) = S
1930                   then
1931                      --  We have found a primitive covered by S
1932
1933                      Store_IS (Interface_Alias (Prim));
1934                   end if;
1935
1936                   Next_Elmt (Elmt);
1937                end loop;
1938             end if;
1939          end;
1940       end if;
1941
1942       return Result (1 .. N);
1943    end Inherited_Subprograms;
1944
1945    ---------------------------
1946    -- Is_Dynamically_Tagged --
1947    ---------------------------
1948
1949    function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
1950    begin
1951       if Nkind (N) = N_Error then
1952          return False;
1953       else
1954          return Find_Controlling_Arg (N) /= Empty;
1955       end if;
1956    end Is_Dynamically_Tagged;
1957
1958    ---------------------------------
1959    -- Is_Null_Interface_Primitive --
1960    ---------------------------------
1961
1962    function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
1963    begin
1964       return Comes_From_Source (E)
1965         and then Is_Dispatching_Operation (E)
1966         and then Ekind (E) = E_Procedure
1967         and then Null_Present (Parent (E))
1968         and then Is_Interface (Find_Dispatching_Type (E));
1969    end Is_Null_Interface_Primitive;
1970
1971    --------------------------
1972    -- Is_Tag_Indeterminate --
1973    --------------------------
1974
1975    function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
1976       Nam       : Entity_Id;
1977       Actual    : Node_Id;
1978       Orig_Node : constant Node_Id := Original_Node (N);
1979
1980    begin
1981       if Nkind (Orig_Node) = N_Function_Call
1982         and then Is_Entity_Name (Name (Orig_Node))
1983       then
1984          Nam := Entity (Name (Orig_Node));
1985
1986          if not Has_Controlling_Result (Nam) then
1987             return False;
1988
1989          --  An explicit dereference means that the call has already been
1990          --  expanded and there is no tag to propagate.
1991
1992          elsif Nkind (N) = N_Explicit_Dereference then
1993             return False;
1994
1995          --  If there are no actuals, the call is tag-indeterminate
1996
1997          elsif No (Parameter_Associations (Orig_Node)) then
1998             return True;
1999
2000          else
2001             Actual := First_Actual (Orig_Node);
2002             while Present (Actual) loop
2003                if Is_Controlling_Actual (Actual)
2004                  and then not Is_Tag_Indeterminate (Actual)
2005                then
2006                   return False; -- one operand is dispatching
2007                end if;
2008
2009                Next_Actual (Actual);
2010             end loop;
2011
2012             return True;
2013          end if;
2014
2015       elsif Nkind (Orig_Node) = N_Qualified_Expression then
2016          return Is_Tag_Indeterminate (Expression (Orig_Node));
2017
2018       --  Case of a call to the Input attribute (possibly rewritten), which is
2019       --  always tag-indeterminate except when its prefix is a Class attribute.
2020
2021       elsif Nkind (Orig_Node) = N_Attribute_Reference
2022         and then
2023           Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
2024         and then
2025           Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
2026       then
2027          return True;
2028
2029       --  In Ada 2005 a function that returns an anonymous access type can
2030       --  dispatching, and the dereference of a call to such a function
2031       --  is also tag-indeterminate.
2032
2033       elsif Nkind (Orig_Node) = N_Explicit_Dereference
2034         and then Ada_Version >= Ada_2005
2035       then
2036          return Is_Tag_Indeterminate (Prefix (Orig_Node));
2037
2038       else
2039          return False;
2040       end if;
2041    end Is_Tag_Indeterminate;
2042
2043    ------------------------------------
2044    -- Override_Dispatching_Operation --
2045    ------------------------------------
2046
2047    procedure Override_Dispatching_Operation
2048      (Tagged_Type : Entity_Id;
2049       Prev_Op     : Entity_Id;
2050       New_Op      : Entity_Id)
2051    is
2052       Elmt : Elmt_Id;
2053       Prim : Node_Id;
2054
2055    begin
2056       --  Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
2057       --  we do it unconditionally in Ada 95 now, since this is our pragma!)
2058
2059       if No_Return (Prev_Op) and then not No_Return (New_Op) then
2060          Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
2061          Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
2062       end if;
2063
2064       --  If there is no previous operation to override, the type declaration
2065       --  was malformed, and an error must have been emitted already.
2066
2067       Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
2068       while Present (Elmt)
2069         and then Node (Elmt) /= Prev_Op
2070       loop
2071          Next_Elmt (Elmt);
2072       end loop;
2073
2074       if No (Elmt) then
2075          return;
2076       end if;
2077
2078       --  The location of entities that come from source in the list of
2079       --  primitives of the tagged type must follow their order of occurrence
2080       --  in the sources to fulfill the C++ ABI. If the overriden entity is a
2081       --  primitive of an interface that is not an ancestor of this tagged
2082       --  type (that is, it is an entity added to the list of primitives by
2083       --  Derive_Interface_Progenitors), then we must append the new entity
2084       --  at the end of the list of primitives.
2085
2086       if Present (Alias (Prev_Op))
2087         and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
2088         and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
2089                                   Tagged_Type)
2090       then
2091          Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt);
2092          Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
2093
2094       --  The new primitive replaces the overriden entity. Required to ensure
2095       --  that overriding primitive is assigned the same dispatch table slot.
2096
2097       else
2098          Replace_Elmt (Elmt, New_Op);
2099       end if;
2100
2101       if Ada_Version >= Ada_2005
2102         and then Has_Interfaces (Tagged_Type)
2103       then
2104          --  Ada 2005 (AI-251): Update the attribute alias of all the aliased
2105          --  entities of the overridden primitive to reference New_Op, and also
2106          --  propagate the proper value of Is_Abstract_Subprogram. Verify
2107          --  that the new operation is subtype conformant with the interface
2108          --  operations that it implements (for operations inherited from the
2109          --  parent itself, this check is made when building the derived type).
2110
2111          --  Note: This code is only executed in case of late overriding
2112
2113          Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
2114          while Present (Elmt) loop
2115             Prim := Node (Elmt);
2116
2117             if Prim = New_Op then
2118                null;
2119
2120             --  Note: The check on Is_Subprogram protects the frontend against
2121             --  reading attributes in entities that are not yet fully decorated
2122
2123             elsif Is_Subprogram (Prim)
2124               and then Present (Interface_Alias (Prim))
2125               and then Alias (Prim) = Prev_Op
2126               and then Present (Etype (New_Op))
2127             then
2128                Set_Alias (Prim, New_Op);
2129                Check_Subtype_Conformant (New_Op, Prim);
2130                Set_Is_Abstract_Subprogram (Prim,
2131                  Is_Abstract_Subprogram (New_Op));
2132
2133                --  Ensure that this entity will be expanded to fill the
2134                --  corresponding entry in its dispatch table.
2135
2136                if not Is_Abstract_Subprogram (Prim) then
2137                   Set_Has_Delayed_Freeze (Prim);
2138                end if;
2139             end if;
2140
2141             Next_Elmt (Elmt);
2142          end loop;
2143       end if;
2144
2145       if (not Is_Package_Or_Generic_Package (Current_Scope))
2146         or else not In_Private_Part (Current_Scope)
2147       then
2148          --  Not a private primitive
2149
2150          null;
2151
2152       else pragma Assert (Is_Inherited_Operation (Prev_Op));
2153
2154          --  Make the overriding operation into an alias of the implicit one.
2155          --  In this fashion a call from outside ends up calling the new body
2156          --  even if non-dispatching, and a call from inside calls the over-
2157          --  riding operation because it hides the implicit one. To indicate
2158          --  that the body of Prev_Op is never called, set its dispatch table
2159          --  entity to Empty. If the overridden operation has a dispatching
2160          --  result, so does the overriding one.
2161
2162          Set_Alias (Prev_Op, New_Op);
2163          Set_DTC_Entity (Prev_Op, Empty);
2164          Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op));
2165          return;
2166       end if;
2167    end Override_Dispatching_Operation;
2168
2169    -------------------
2170    -- Propagate_Tag --
2171    -------------------
2172
2173    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
2174       Call_Node : Node_Id;
2175       Arg       : Node_Id;
2176
2177    begin
2178       if Nkind (Actual) = N_Function_Call then
2179          Call_Node := Actual;
2180
2181       elsif Nkind (Actual) = N_Identifier
2182         and then Nkind (Original_Node (Actual)) = N_Function_Call
2183       then
2184          --  Call rewritten as object declaration when stack-checking is
2185          --  enabled. Propagate tag to expression in declaration, which is
2186          --  original call.
2187
2188          Call_Node := Expression (Parent (Entity (Actual)));
2189
2190       --  Ada 2005: If this is a dereference of a call to a function with a
2191       --  dispatching access-result, the tag is propagated when the dereference
2192       --  itself is expanded (see exp_ch6.adb) and there is nothing else to do.
2193
2194       elsif Nkind (Actual) = N_Explicit_Dereference
2195         and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
2196       then
2197          return;
2198
2199       --  Only other possibilities are parenthesized or qualified expression,
2200       --  or an expander-generated unchecked conversion of a function call to
2201       --  a stream Input attribute.
2202
2203       else
2204          Call_Node := Expression (Actual);
2205       end if;
2206
2207       --  Do not set the Controlling_Argument if already set. This happens in
2208       --  the special case of _Input (see Exp_Attr, case Input).
2209
2210       if No (Controlling_Argument (Call_Node)) then
2211          Set_Controlling_Argument (Call_Node, Control);
2212       end if;
2213
2214       Arg := First_Actual (Call_Node);
2215       while Present (Arg) loop
2216          if Is_Tag_Indeterminate (Arg) then
2217             Propagate_Tag (Control,  Arg);
2218          end if;
2219
2220          Next_Actual (Arg);
2221       end loop;
2222
2223       --  Expansion of dispatching calls is suppressed when VM_Target, because
2224       --  the VM back-ends directly handle the generation of dispatching calls
2225       --  and would have to undo any expansion to an indirect call.
2226
2227       if Tagged_Type_Expansion then
2228          declare
2229             Call_Typ : constant Entity_Id := Etype (Call_Node);
2230
2231          begin
2232             Expand_Dispatching_Call (Call_Node);
2233
2234             --  If the controlling argument is an interface type and the type
2235             --  of Call_Node differs then we must add an implicit conversion to
2236             --  force displacement of the pointer to the object to reference
2237             --  the secondary dispatch table of the interface.
2238
2239             if Is_Interface (Etype (Control))
2240               and then Etype (Control) /= Call_Typ
2241             then
2242                --  Cannot use Convert_To because the previous call to
2243                --  Expand_Dispatching_Call leaves decorated the Call_Node
2244                --  with the type of Control.
2245
2246                Rewrite (Call_Node,
2247                  Make_Type_Conversion (Sloc (Call_Node),
2248                    Subtype_Mark =>
2249                      New_Occurrence_Of (Etype (Control), Sloc (Call_Node)),
2250                    Expression => Relocate_Node (Call_Node)));
2251                Set_Etype (Call_Node, Etype (Control));
2252                Set_Analyzed (Call_Node);
2253
2254                Expand_Interface_Conversion (Call_Node, Is_Static => False);
2255             end if;
2256          end;
2257
2258       --  Expansion of a dispatching call results in an indirect call, which in
2259       --  turn causes current values to be killed (see Resolve_Call), so on VM
2260       --  targets we do the call here to ensure consistent warnings between VM
2261       --  and non-VM targets.
2262
2263       else
2264          Kill_Current_Values;
2265       end if;
2266    end Propagate_Tag;
2267
2268 end Sem_Disp;