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 Is_Overriding_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_Is_Overriding_Operation (Subp, False);
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             Set_Is_Overriding_Operation (Subp);
1143
1144             --  Ada 2005 (AI-251): In case of late overriding of a primitive
1145             --  that covers abstract interface subprograms we must register it
1146             --  in all the secondary dispatch tables associated with abstract
1147             --  interfaces. We do this now only if not building static tables.
1148             --  Otherwise the patch code is emitted after those tables are
1149             --  built, to prevent access_before_elaboration in gigi.
1150
1151             if Body_Is_Last_Primitive then
1152                declare
1153                   Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
1154                   Elmt      : Elmt_Id;
1155                   Prim      : Node_Id;
1156
1157                begin
1158                   Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1159                   while Present (Elmt) loop
1160                      Prim := Node (Elmt);
1161
1162                      if Present (Alias (Prim))
1163                        and then Present (Interface_Alias (Prim))
1164                        and then Alias (Prim) = Subp
1165                        and then not Building_Static_DT (Tagged_Type)
1166                      then
1167                         Insert_Actions_After (Subp_Body,
1168                           Register_Primitive (Sloc (Subp_Body), Prim => Prim));
1169                      end if;
1170
1171                      Next_Elmt (Elmt);
1172                   end loop;
1173
1174                   --  Redisplay the contents of the updated dispatch table
1175
1176                   if Debug_Flag_ZZ then
1177                      Write_Str ("Late overriding: ");
1178                      Write_DT (Tagged_Type);
1179                   end if;
1180                end;
1181             end if;
1182          end if;
1183
1184       --  If the tagged type is a concurrent type then we must be compiling
1185       --  with no code generation (we are either compiling a generic unit or
1186       --  compiling under -gnatc mode) because we have previously tested that
1187       --  no serious errors has been reported. In this case we do not add the
1188       --  primitive to the list of primitives of Tagged_Type but we leave the
1189       --  primitive decorated as a dispatching operation to be able to analyze
1190       --  and report errors associated with the Object.Operation notation.
1191
1192       elsif Is_Concurrent_Type (Tagged_Type) then
1193          pragma Assert (not Expander_Active);
1194          null;
1195
1196       --  If no old subprogram, then we add this as a dispatching operation,
1197       --  but we avoid doing this if an error was posted, to prevent annoying
1198       --  cascaded errors.
1199
1200       elsif not Error_Posted (Subp) then
1201          Add_Dispatching_Operation (Tagged_Type, Subp);
1202       end if;
1203
1204       Set_Is_Dispatching_Operation (Subp, True);
1205
1206       --  Ada 2005 (AI-251): If the type implements interfaces we must check
1207       --  subtype conformance against all the interfaces covered by this
1208       --  primitive.
1209
1210       if Present (Ovr_Subp)
1211         and then Has_Interfaces (Tagged_Type)
1212       then
1213          declare
1214             Ifaces_List     : Elist_Id;
1215             Iface_Elmt      : Elmt_Id;
1216             Iface_Prim_Elmt : Elmt_Id;
1217             Iface_Prim      : Entity_Id;
1218             Ret_Typ         : Entity_Id;
1219
1220          begin
1221             Collect_Interfaces (Tagged_Type, Ifaces_List);
1222
1223             Iface_Elmt := First_Elmt (Ifaces_List);
1224             while Present (Iface_Elmt) loop
1225                if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then
1226                   Iface_Prim_Elmt :=
1227                     First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
1228                   while Present (Iface_Prim_Elmt) loop
1229                      Iface_Prim := Node (Iface_Prim_Elmt);
1230
1231                      if Is_Interface_Conformant
1232                           (Tagged_Type, Iface_Prim, Subp)
1233                      then
1234                         --  Handle procedures, functions whose return type
1235                         --  matches, or functions not returning interfaces
1236
1237                         if Ekind (Subp) = E_Procedure
1238                           or else Etype (Iface_Prim) = Etype (Subp)
1239                           or else not Is_Interface (Etype (Iface_Prim))
1240                         then
1241                            Check_Subtype_Conformant
1242                              (New_Id  => Subp,
1243                               Old_Id  => Iface_Prim,
1244                               Err_Loc => Subp,
1245                               Skip_Controlling_Formals => True);
1246
1247                         --  Handle functions returning interfaces
1248
1249                         elsif Implements_Interface
1250                                 (Etype (Subp), Etype (Iface_Prim))
1251                         then
1252                            --  Temporarily force both entities to return the
1253                            --  same type. Required because Subtype_Conformant
1254                            --  does not handle this case.
1255
1256                            Ret_Typ := Etype (Iface_Prim);
1257                            Set_Etype (Iface_Prim, Etype (Subp));
1258
1259                            Check_Subtype_Conformant
1260                              (New_Id  => Subp,
1261                               Old_Id  => Iface_Prim,
1262                               Err_Loc => Subp,
1263                               Skip_Controlling_Formals => True);
1264
1265                            Set_Etype (Iface_Prim, Ret_Typ);
1266                         end if;
1267                      end if;
1268
1269                      Next_Elmt (Iface_Prim_Elmt);
1270                   end loop;
1271                end if;
1272
1273                Next_Elmt (Iface_Elmt);
1274             end loop;
1275          end;
1276       end if;
1277
1278       if not Body_Is_Last_Primitive then
1279          Set_DT_Position (Subp, No_Uint);
1280
1281       elsif Has_Controlled_Component (Tagged_Type)
1282         and then
1283          (Chars (Subp) = Name_Initialize
1284             or else
1285           Chars (Subp) = Name_Adjust
1286             or else
1287           Chars (Subp) = Name_Finalize)
1288       then
1289          declare
1290             F_Node   : constant Node_Id := Freeze_Node (Tagged_Type);
1291             Decl     : Node_Id;
1292             Old_P    : Entity_Id;
1293             Old_Bod  : Node_Id;
1294             Old_Spec : Entity_Id;
1295
1296             C_Names : constant array (1 .. 3) of Name_Id :=
1297                         (Name_Initialize,
1298                          Name_Adjust,
1299                          Name_Finalize);
1300
1301             D_Names : constant array (1 .. 3) of TSS_Name_Type :=
1302                         (TSS_Deep_Initialize,
1303                          TSS_Deep_Adjust,
1304                          TSS_Deep_Finalize);
1305
1306          begin
1307             --  Remove previous controlled function which was constructed and
1308             --  analyzed when the type was frozen. This requires removing the
1309             --  body of the redefined primitive, as well as its specification
1310             --  if needed (there is no spec created for Deep_Initialize, see
1311             --  exp_ch3.adb). We must also dismantle the exception information
1312             --  that may have been generated for it when front end zero-cost
1313             --  tables are enabled.
1314
1315             for J in D_Names'Range loop
1316                Old_P := TSS (Tagged_Type, D_Names (J));
1317
1318                if Present (Old_P)
1319                 and then Chars (Subp) = C_Names (J)
1320                then
1321                   Old_Bod := Unit_Declaration_Node (Old_P);
1322                   Remove (Old_Bod);
1323                   Set_Is_Eliminated (Old_P);
1324                   Set_Scope (Old_P,  Scope (Current_Scope));
1325
1326                   if Nkind (Old_Bod) = N_Subprogram_Body
1327                     and then Present (Corresponding_Spec (Old_Bod))
1328                   then
1329                      Old_Spec := Corresponding_Spec (Old_Bod);
1330                      Set_Has_Completion             (Old_Spec, False);
1331                   end if;
1332                end if;
1333             end loop;
1334
1335             Build_Late_Proc (Tagged_Type, Chars (Subp));
1336
1337             --  The new operation is added to the actions of the freeze node
1338             --  for the type, but this node has already been analyzed, so we
1339             --  must retrieve and analyze explicitly the new body.
1340
1341             if Present (F_Node)
1342               and then Present (Actions (F_Node))
1343             then
1344                Decl := Last (Actions (F_Node));
1345                Analyze (Decl);
1346             end if;
1347          end;
1348       end if;
1349    end Check_Dispatching_Operation;
1350
1351    ------------------------------------------
1352    -- Check_Operation_From_Incomplete_Type --
1353    ------------------------------------------
1354
1355    procedure Check_Operation_From_Incomplete_Type
1356      (Subp : Entity_Id;
1357       Typ  : Entity_Id)
1358    is
1359       Full       : constant Entity_Id := Full_View (Typ);
1360       Parent_Typ : constant Entity_Id := Etype (Full);
1361       Old_Prim   : constant Elist_Id  := Primitive_Operations (Parent_Typ);
1362       New_Prim   : constant Elist_Id  := Primitive_Operations (Full);
1363       Op1, Op2   : Elmt_Id;
1364       Prev       : Elmt_Id := No_Elmt;
1365
1366       function Derives_From (Proc : Entity_Id) return Boolean;
1367       --  Check that Subp has the signature of an operation derived from Proc.
1368       --  Subp has an access parameter that designates Typ.
1369
1370       ------------------
1371       -- Derives_From --
1372       ------------------
1373
1374       function Derives_From (Proc : Entity_Id) return Boolean is
1375          F1, F2 : Entity_Id;
1376
1377       begin
1378          if Chars (Proc) /= Chars (Subp) then
1379             return False;
1380          end if;
1381
1382          F1 := First_Formal (Proc);
1383          F2 := First_Formal (Subp);
1384          while Present (F1) and then Present (F2) loop
1385             if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
1386                if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
1387                   return False;
1388                elsif Designated_Type (Etype (F1)) = Parent_Typ
1389                  and then Designated_Type (Etype (F2)) /= Full
1390                then
1391                   return False;
1392                end if;
1393
1394             elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
1395                return False;
1396
1397             elsif Etype (F1) /= Etype (F2) then
1398                return False;
1399             end if;
1400
1401             Next_Formal (F1);
1402             Next_Formal (F2);
1403          end loop;
1404
1405          return No (F1) and then No (F2);
1406       end Derives_From;
1407
1408    --  Start of processing for Check_Operation_From_Incomplete_Type
1409
1410    begin
1411       --  The operation may override an inherited one, or may be a new one
1412       --  altogether. The inherited operation will have been hidden by the
1413       --  current one at the point of the type derivation, so it does not
1414       --  appear in the list of primitive operations of the type. We have to
1415       --  find the proper place of insertion in the list of primitive opera-
1416       --  tions by iterating over the list for the parent type.
1417
1418       Op1 := First_Elmt (Old_Prim);
1419       Op2 := First_Elmt (New_Prim);
1420       while Present (Op1) and then Present (Op2) loop
1421          if Derives_From (Node (Op1)) then
1422             if No (Prev) then
1423
1424                --  Avoid adding it to the list of primitives if already there!
1425
1426                if Node (Op2) /= Subp then
1427                   Prepend_Elmt (Subp, New_Prim);
1428                end if;
1429
1430             else
1431                Insert_Elmt_After (Subp, Prev);
1432             end if;
1433
1434             return;
1435          end if;
1436
1437          Prev := Op2;
1438          Next_Elmt (Op1);
1439          Next_Elmt (Op2);
1440       end loop;
1441
1442       --  Operation is a new primitive
1443
1444       Append_Elmt (Subp, New_Prim);
1445    end Check_Operation_From_Incomplete_Type;
1446
1447    ---------------------------------------
1448    -- Check_Operation_From_Private_View --
1449    ---------------------------------------
1450
1451    procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
1452       Tagged_Type : Entity_Id;
1453
1454    begin
1455       if Is_Dispatching_Operation (Alias (Subp)) then
1456          Set_Scope (Subp, Current_Scope);
1457          Tagged_Type := Find_Dispatching_Type (Subp);
1458
1459          --  Add Old_Subp to primitive operations if not already present
1460
1461          if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
1462             Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
1463
1464             --  If Old_Subp isn't already marked as dispatching then
1465             --  this is the case of an operation of an untagged private
1466             --  type fulfilled by a tagged type that overrides an
1467             --  inherited dispatching operation, so we set the necessary
1468             --  dispatching attributes here.
1469
1470             if not Is_Dispatching_Operation (Old_Subp) then
1471
1472                --  If the untagged type has no discriminants, and the full
1473                --  view is constrained, there will be a spurious mismatch
1474                --  of subtypes on the controlling arguments, because the tagged
1475                --  type is the internal base type introduced in the derivation.
1476                --  Use the original type to verify conformance, rather than the
1477                --  base type.
1478
1479                if not Comes_From_Source (Tagged_Type)
1480                  and then Has_Discriminants (Tagged_Type)
1481                then
1482                   declare
1483                      Formal : Entity_Id;
1484
1485                   begin
1486                      Formal := First_Formal (Old_Subp);
1487                      while Present (Formal) loop
1488                         if Tagged_Type = Base_Type (Etype (Formal)) then
1489                            Tagged_Type := Etype (Formal);
1490                         end if;
1491
1492                         Next_Formal (Formal);
1493                      end loop;
1494                   end;
1495
1496                   if Tagged_Type = Base_Type (Etype (Old_Subp)) then
1497                      Tagged_Type := Etype (Old_Subp);
1498                   end if;
1499                end if;
1500
1501                Check_Controlling_Formals (Tagged_Type, Old_Subp);
1502                Set_Is_Dispatching_Operation (Old_Subp, True);
1503                Set_DT_Position (Old_Subp, No_Uint);
1504             end if;
1505
1506             --  If the old subprogram is an explicit renaming of some other
1507             --  entity, it is not overridden by the inherited subprogram.
1508             --  Otherwise, update its alias and other attributes.
1509
1510             if Present (Alias (Old_Subp))
1511               and then Nkind (Unit_Declaration_Node (Old_Subp)) /=
1512                                         N_Subprogram_Renaming_Declaration
1513             then
1514                Set_Alias (Old_Subp, Alias (Subp));
1515
1516                --  The derived subprogram should inherit the abstractness
1517                --  of the parent subprogram (except in the case of a function
1518                --  returning the type). This sets the abstractness properly
1519                --  for cases where a private extension may have inherited
1520                --  an abstract operation, but the full type is derived from
1521                --  a descendant type and inherits a nonabstract version.
1522
1523                if Etype (Subp) /= Tagged_Type then
1524                   Set_Is_Abstract_Subprogram
1525                     (Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
1526                end if;
1527             end if;
1528          end if;
1529       end if;
1530    end Check_Operation_From_Private_View;
1531
1532    --------------------------
1533    -- Find_Controlling_Arg --
1534    --------------------------
1535
1536    function Find_Controlling_Arg (N : Node_Id) return Node_Id is
1537       Orig_Node : constant Node_Id := Original_Node (N);
1538       Typ       : Entity_Id;
1539
1540    begin
1541       if Nkind (Orig_Node) = N_Qualified_Expression then
1542          return Find_Controlling_Arg (Expression (Orig_Node));
1543       end if;
1544
1545       --  Dispatching on result case. If expansion is disabled, the node still
1546       --  has the structure of a function call. However, if the function name
1547       --  is an operator and the call was given in infix form, the original
1548       --  node has no controlling result and we must examine the current node.
1549
1550       if Nkind (N) = N_Function_Call
1551         and then Present (Controlling_Argument (N))
1552         and then Has_Controlling_Result (Entity (Name (N)))
1553       then
1554          return Controlling_Argument (N);
1555
1556       --  If expansion is enabled, the call may have been transformed into
1557       --  an indirect call, and we need to recover the original node.
1558
1559       elsif Nkind (Orig_Node) = N_Function_Call
1560         and then Present (Controlling_Argument (Orig_Node))
1561         and then Has_Controlling_Result (Entity (Name (Orig_Node)))
1562       then
1563          return Controlling_Argument (Orig_Node);
1564
1565       --  Normal case
1566
1567       elsif Is_Controlling_Actual (N)
1568         or else
1569          (Nkind (Parent (N)) = N_Qualified_Expression
1570            and then Is_Controlling_Actual (Parent (N)))
1571       then
1572          Typ := Etype (N);
1573
1574          if Is_Access_Type (Typ) then
1575
1576             --  In the case of an Access attribute, use the type of the prefix,
1577             --  since in the case of an actual for an access parameter, the
1578             --  attribute's type may be of a specific designated type, even
1579             --  though the prefix type is class-wide.
1580
1581             if Nkind (N) = N_Attribute_Reference then
1582                Typ := Etype (Prefix (N));
1583
1584             --  An allocator is dispatching if the type of qualified expression
1585             --  is class_wide, in which case this is the controlling type.
1586
1587             elsif Nkind (Orig_Node) = N_Allocator
1588                and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
1589             then
1590                Typ := Etype (Expression (Orig_Node));
1591             else
1592                Typ := Designated_Type (Typ);
1593             end if;
1594          end if;
1595
1596          if Is_Class_Wide_Type (Typ)
1597            or else
1598              (Nkind (Parent (N)) = N_Qualified_Expression
1599                and then Is_Access_Type (Etype (N))
1600                and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
1601          then
1602             return N;
1603          end if;
1604       end if;
1605
1606       return Empty;
1607    end Find_Controlling_Arg;
1608
1609    ---------------------------
1610    -- Find_Dispatching_Type --
1611    ---------------------------
1612
1613    function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
1614       A_Formal  : Entity_Id;
1615       Formal    : Entity_Id;
1616       Ctrl_Type : Entity_Id;
1617
1618    begin
1619       if Present (DTC_Entity (Subp)) then
1620          return Scope (DTC_Entity (Subp));
1621
1622       --  For subprograms internally generated by derivations of tagged types
1623       --  use the alias subprogram as a reference to locate the dispatching
1624       --  type of Subp.
1625
1626       elsif not Comes_From_Source (Subp)
1627         and then Present (Alias (Subp))
1628         and then Is_Dispatching_Operation (Alias (Subp))
1629       then
1630          if Ekind (Alias (Subp)) = E_Function
1631            and then Has_Controlling_Result (Alias (Subp))
1632          then
1633             return Check_Controlling_Type (Etype (Subp), Subp);
1634
1635          else
1636             Formal   := First_Formal (Subp);
1637             A_Formal := First_Formal (Alias (Subp));
1638             while Present (A_Formal) loop
1639                if Is_Controlling_Formal (A_Formal) then
1640                   return Check_Controlling_Type (Etype (Formal), Subp);
1641                end if;
1642
1643                Next_Formal (Formal);
1644                Next_Formal (A_Formal);
1645             end loop;
1646
1647             pragma Assert (False);
1648             return Empty;
1649          end if;
1650
1651       --  General case
1652
1653       else
1654          Formal := First_Formal (Subp);
1655          while Present (Formal) loop
1656             Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
1657
1658             if Present (Ctrl_Type) then
1659                return Ctrl_Type;
1660             end if;
1661
1662             Next_Formal (Formal);
1663          end loop;
1664
1665          --  The subprogram may also be dispatching on result
1666
1667          if Present (Etype (Subp)) then
1668             return Check_Controlling_Type (Etype (Subp), Subp);
1669          end if;
1670       end if;
1671
1672       pragma Assert (not Is_Dispatching_Operation (Subp));
1673       return Empty;
1674    end Find_Dispatching_Type;
1675
1676    --------------------------------------
1677    -- Find_Hidden_Overridden_Primitive --
1678    --------------------------------------
1679
1680    function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id
1681    is
1682       Tag_Typ   : constant Entity_Id := Find_Dispatching_Type (S);
1683       Elmt      : Elmt_Id;
1684       Orig_Prim : Entity_Id;
1685       Prim      : Entity_Id;
1686       Vis_List  : Elist_Id;
1687
1688    begin
1689       --  This Ada 2012 rule is valid only for type extensions or private
1690       --  extensions
1691
1692       if No (Tag_Typ)
1693         or else not Is_Record_Type (Tag_Typ)
1694         or else Etype (Tag_Typ) = Tag_Typ
1695       then
1696          return Empty;
1697       end if;
1698
1699       --  Collect the list of visible ancestor of the tagged type
1700
1701       Vis_List := Visible_Ancestors (Tag_Typ);
1702
1703       Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
1704       while Present (Elmt) loop
1705          Prim := Node (Elmt);
1706
1707          --  Find an inherited hidden dispatching primitive with the name of S
1708          --  and a type-conformant profile
1709
1710          if Present (Alias (Prim))
1711            and then Is_Hidden (Alias (Prim))
1712            and then Find_Dispatching_Type (Alias (Prim)) /= Tag_Typ
1713            and then Primitive_Names_Match (S, Prim)
1714            and then Type_Conformant (S, Prim)
1715          then
1716             declare
1717                Vis_Ancestor : Elmt_Id;
1718                Elmt         : Elmt_Id;
1719
1720             begin
1721                --  The original corresponding operation of Prim must be an
1722                --  operation of a visible ancestor of the dispatching type
1723                --  of S, and the original corresponding operation of S2 must
1724                --  be visible.
1725
1726                Orig_Prim := Original_Corresponding_Operation (Prim);
1727
1728                if Orig_Prim /= Prim
1729                  and then Is_Immediately_Visible (Orig_Prim)
1730                then
1731                   Vis_Ancestor := First_Elmt (Vis_List);
1732
1733                   while Present (Vis_Ancestor) loop
1734                      Elmt :=
1735                        First_Elmt (Primitive_Operations (Node (Vis_Ancestor)));
1736                      while Present (Elmt) loop
1737                         if Node (Elmt) = Orig_Prim then
1738                            Set_Overridden_Operation (S, Prim);
1739                            Set_Alias (Prim, Orig_Prim);
1740
1741                            return Prim;
1742                         end if;
1743
1744                         Next_Elmt (Elmt);
1745                      end loop;
1746
1747                      Next_Elmt (Vis_Ancestor);
1748                   end loop;
1749                end if;
1750             end;
1751          end if;
1752
1753          Next_Elmt (Elmt);
1754       end loop;
1755
1756       return Empty;
1757    end Find_Hidden_Overridden_Primitive;
1758
1759    ---------------------------------------
1760    -- Find_Primitive_Covering_Interface --
1761    ---------------------------------------
1762
1763    function Find_Primitive_Covering_Interface
1764      (Tagged_Type : Entity_Id;
1765       Iface_Prim  : Entity_Id) return Entity_Id
1766    is
1767       E  : Entity_Id;
1768       El : Elmt_Id;
1769
1770    begin
1771       pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
1772         or else (Present (Alias (Iface_Prim))
1773                    and then
1774                      Is_Interface
1775                        (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
1776
1777       --  Search in the homonym chain. Done to speed up locating visible
1778       --  entities and required to catch primitives associated with the partial
1779       --  view of private types when processing the corresponding full view.
1780
1781       E := Current_Entity (Iface_Prim);
1782       while Present (E) loop
1783          if Is_Subprogram (E)
1784            and then Is_Dispatching_Operation (E)
1785            and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E)
1786          then
1787             return E;
1788          end if;
1789
1790          E := Homonym (E);
1791       end loop;
1792
1793       --  Search in the list of primitives of the type. Required to locate the
1794       --  covering primitive if the covering primitive is not visible (for
1795       --  example, non-visible inherited primitive of private type).
1796
1797       El := First_Elmt (Primitive_Operations (Tagged_Type));
1798       while Present (El) loop
1799          E := Node (El);
1800
1801          --  Keep separate the management of internal entities that link
1802          --  primitives with interface primitives from tagged type primitives.
1803
1804          if No (Interface_Alias (E)) then
1805             if Present (Alias (E)) then
1806
1807                --  This interface primitive has not been covered yet
1808
1809                if Alias (E) = Iface_Prim then
1810                   return E;
1811
1812                --  The covering primitive was inherited
1813
1814                elsif Overridden_Operation (Ultimate_Alias (E))
1815                        = Iface_Prim
1816                then
1817                   return E;
1818                end if;
1819             end if;
1820
1821          --  Use the internal entity that links the interface primitive with
1822          --  the covering primitive to locate the entity
1823
1824          elsif Interface_Alias (E) = Iface_Prim then
1825             return Alias (E);
1826          end if;
1827
1828          Next_Elmt (El);
1829       end loop;
1830
1831       --  Not found
1832
1833       return Empty;
1834    end Find_Primitive_Covering_Interface;
1835
1836    ---------------------------
1837    -- Inherited_Subprograms --
1838    ---------------------------
1839
1840    function Inherited_Subprograms (S : Entity_Id) return Subprogram_List is
1841       Result : Subprogram_List (1 .. 6000);
1842       --  6000 here is intended to be infinity. We could use an expandable
1843       --  table, but it would be awfully heavy, and there is no way that we
1844       --  could reasonably exceed this value.
1845
1846       N : Int := 0;
1847       --  Number of entries in Result
1848
1849       Parent_Op : Entity_Id;
1850       --  Traverses the Overridden_Operation chain
1851
1852       procedure Store_IS (E : Entity_Id);
1853       --  Stores E in Result if not already stored
1854
1855       --------------
1856       -- Store_IS --
1857       --------------
1858
1859       procedure Store_IS (E : Entity_Id) is
1860       begin
1861          for J in 1 .. N loop
1862             if E = Result (J) then
1863                return;
1864             end if;
1865          end loop;
1866
1867          N := N + 1;
1868          Result (N) := E;
1869       end Store_IS;
1870
1871    --  Start of processing for Inherited_Subprograms
1872
1873    begin
1874       if Present (S) and then Is_Dispatching_Operation (S) then
1875
1876          --  Deal with direct inheritance
1877
1878          Parent_Op := S;
1879          loop
1880             Parent_Op := Overridden_Operation (Parent_Op);
1881             exit when No (Parent_Op);
1882
1883             if Is_Subprogram (Parent_Op)
1884               or else Is_Generic_Subprogram (Parent_Op)
1885             then
1886                Store_IS (Parent_Op);
1887             end if;
1888          end loop;
1889
1890          --  Now deal with interfaces
1891
1892          declare
1893             Tag_Typ : Entity_Id;
1894             Prim    : Entity_Id;
1895             Elmt    : Elmt_Id;
1896
1897          begin
1898             Tag_Typ := Find_Dispatching_Type (S);
1899
1900             if Is_Concurrent_Type (Tag_Typ) then
1901                Tag_Typ := Corresponding_Record_Type (Tag_Typ);
1902             end if;
1903
1904             --  Search primitive operations of dispatching type
1905
1906             if Present (Tag_Typ)
1907               and then Present (Primitive_Operations (Tag_Typ))
1908             then
1909                Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
1910                while Present (Elmt) loop
1911                   Prim := Node (Elmt);
1912
1913                   --  The following test eliminates some odd cases in which
1914                   --  Ekind (Prim) is Void, to be investigated further ???
1915
1916                   if not (Is_Subprogram (Prim)
1917                             or else
1918                           Is_Generic_Subprogram (Prim))
1919                   then
1920                      null;
1921
1922                      --  For [generic] subprogram, look at interface alias
1923
1924                   elsif Present (Interface_Alias (Prim))
1925                     and then Alias (Prim) = S
1926                   then
1927                      --  We have found a primitive covered by S
1928
1929                      Store_IS (Interface_Alias (Prim));
1930                   end if;
1931
1932                   Next_Elmt (Elmt);
1933                end loop;
1934             end if;
1935          end;
1936       end if;
1937
1938       return Result (1 .. N);
1939    end Inherited_Subprograms;
1940
1941    ---------------------------
1942    -- Is_Dynamically_Tagged --
1943    ---------------------------
1944
1945    function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
1946    begin
1947       if Nkind (N) = N_Error then
1948          return False;
1949       else
1950          return Find_Controlling_Arg (N) /= Empty;
1951       end if;
1952    end Is_Dynamically_Tagged;
1953
1954    ---------------------------------
1955    -- Is_Null_Interface_Primitive --
1956    ---------------------------------
1957
1958    function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
1959    begin
1960       return Comes_From_Source (E)
1961         and then Is_Dispatching_Operation (E)
1962         and then Ekind (E) = E_Procedure
1963         and then Null_Present (Parent (E))
1964         and then Is_Interface (Find_Dispatching_Type (E));
1965    end Is_Null_Interface_Primitive;
1966
1967    --------------------------
1968    -- Is_Tag_Indeterminate --
1969    --------------------------
1970
1971    function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
1972       Nam       : Entity_Id;
1973       Actual    : Node_Id;
1974       Orig_Node : constant Node_Id := Original_Node (N);
1975
1976    begin
1977       if Nkind (Orig_Node) = N_Function_Call
1978         and then Is_Entity_Name (Name (Orig_Node))
1979       then
1980          Nam := Entity (Name (Orig_Node));
1981
1982          if not Has_Controlling_Result (Nam) then
1983             return False;
1984
1985          --  An explicit dereference means that the call has already been
1986          --  expanded and there is no tag to propagate.
1987
1988          elsif Nkind (N) = N_Explicit_Dereference then
1989             return False;
1990
1991          --  If there are no actuals, the call is tag-indeterminate
1992
1993          elsif No (Parameter_Associations (Orig_Node)) then
1994             return True;
1995
1996          else
1997             Actual := First_Actual (Orig_Node);
1998             while Present (Actual) loop
1999                if Is_Controlling_Actual (Actual)
2000                  and then not Is_Tag_Indeterminate (Actual)
2001                then
2002                   return False; -- one operand is dispatching
2003                end if;
2004
2005                Next_Actual (Actual);
2006             end loop;
2007
2008             return True;
2009          end if;
2010
2011       elsif Nkind (Orig_Node) = N_Qualified_Expression then
2012          return Is_Tag_Indeterminate (Expression (Orig_Node));
2013
2014       --  Case of a call to the Input attribute (possibly rewritten), which is
2015       --  always tag-indeterminate except when its prefix is a Class attribute.
2016
2017       elsif Nkind (Orig_Node) = N_Attribute_Reference
2018         and then
2019           Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
2020         and then
2021           Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
2022       then
2023          return True;
2024
2025       --  In Ada 2005 a function that returns an anonymous access type can
2026       --  dispatching, and the dereference of a call to such a function
2027       --  is also tag-indeterminate.
2028
2029       elsif Nkind (Orig_Node) = N_Explicit_Dereference
2030         and then Ada_Version >= Ada_2005
2031       then
2032          return Is_Tag_Indeterminate (Prefix (Orig_Node));
2033
2034       else
2035          return False;
2036       end if;
2037    end Is_Tag_Indeterminate;
2038
2039    ------------------------------------
2040    -- Override_Dispatching_Operation --
2041    ------------------------------------
2042
2043    procedure Override_Dispatching_Operation
2044      (Tagged_Type : Entity_Id;
2045       Prev_Op     : Entity_Id;
2046       New_Op      : Entity_Id)
2047    is
2048       Elmt : Elmt_Id;
2049       Prim : Node_Id;
2050
2051    begin
2052       --  Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
2053       --  we do it unconditionally in Ada 95 now, since this is our pragma!)
2054
2055       if No_Return (Prev_Op) and then not No_Return (New_Op) then
2056          Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
2057          Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
2058       end if;
2059
2060       --  If there is no previous operation to override, the type declaration
2061       --  was malformed, and an error must have been emitted already.
2062
2063       Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
2064       while Present (Elmt)
2065         and then Node (Elmt) /= Prev_Op
2066       loop
2067          Next_Elmt (Elmt);
2068       end loop;
2069
2070       if No (Elmt) then
2071          return;
2072       end if;
2073
2074       --  The location of entities that come from source in the list of
2075       --  primitives of the tagged type must follow their order of occurrence
2076       --  in the sources to fulfill the C++ ABI. If the overriden entity is a
2077       --  primitive of an interface that is not an ancestor of this tagged
2078       --  type (that is, it is an entity added to the list of primitives by
2079       --  Derive_Interface_Progenitors), then we must append the new entity
2080       --  at the end of the list of primitives.
2081
2082       if Present (Alias (Prev_Op))
2083         and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
2084         and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
2085                                   Tagged_Type)
2086       then
2087          Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt);
2088          Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
2089
2090       --  The new primitive replaces the overriden entity. Required to ensure
2091       --  that overriding primitive is assigned the same dispatch table slot.
2092
2093       else
2094          Replace_Elmt (Elmt, New_Op);
2095       end if;
2096
2097       if Ada_Version >= Ada_2005
2098         and then Has_Interfaces (Tagged_Type)
2099       then
2100          --  Ada 2005 (AI-251): Update the attribute alias of all the aliased
2101          --  entities of the overridden primitive to reference New_Op, and also
2102          --  propagate the proper value of Is_Abstract_Subprogram. Verify
2103          --  that the new operation is subtype conformant with the interface
2104          --  operations that it implements (for operations inherited from the
2105          --  parent itself, this check is made when building the derived type).
2106
2107          --  Note: This code is only executed in case of late overriding
2108
2109          Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
2110          while Present (Elmt) loop
2111             Prim := Node (Elmt);
2112
2113             if Prim = New_Op then
2114                null;
2115
2116             --  Note: The check on Is_Subprogram protects the frontend against
2117             --  reading attributes in entities that are not yet fully decorated
2118
2119             elsif Is_Subprogram (Prim)
2120               and then Present (Interface_Alias (Prim))
2121               and then Alias (Prim) = Prev_Op
2122               and then Present (Etype (New_Op))
2123             then
2124                Set_Alias (Prim, New_Op);
2125                Check_Subtype_Conformant (New_Op, Prim);
2126                Set_Is_Abstract_Subprogram (Prim,
2127                  Is_Abstract_Subprogram (New_Op));
2128
2129                --  Ensure that this entity will be expanded to fill the
2130                --  corresponding entry in its dispatch table.
2131
2132                if not Is_Abstract_Subprogram (Prim) then
2133                   Set_Has_Delayed_Freeze (Prim);
2134                end if;
2135             end if;
2136
2137             Next_Elmt (Elmt);
2138          end loop;
2139       end if;
2140
2141       if (not Is_Package_Or_Generic_Package (Current_Scope))
2142         or else not In_Private_Part (Current_Scope)
2143       then
2144          --  Not a private primitive
2145
2146          null;
2147
2148       else pragma Assert (Is_Inherited_Operation (Prev_Op));
2149
2150          --  Make the overriding operation into an alias of the implicit one.
2151          --  In this fashion a call from outside ends up calling the new body
2152          --  even if non-dispatching, and a call from inside calls the
2153          --  overriding operation because it hides the implicit one. To
2154          --  indicate that the body of Prev_Op is never called, set its
2155          --  dispatch table entity to Empty. If the overridden operation
2156          --  has a dispatching result, so does the overriding one.
2157
2158          Set_Alias (Prev_Op, New_Op);
2159          Set_DTC_Entity (Prev_Op, Empty);
2160          Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op));
2161          return;
2162       end if;
2163    end Override_Dispatching_Operation;
2164
2165    -------------------
2166    -- Propagate_Tag --
2167    -------------------
2168
2169    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
2170       Call_Node : Node_Id;
2171       Arg       : Node_Id;
2172
2173    begin
2174       if Nkind (Actual) = N_Function_Call then
2175          Call_Node := Actual;
2176
2177       elsif Nkind (Actual) = N_Identifier
2178         and then Nkind (Original_Node (Actual)) = N_Function_Call
2179       then
2180          --  Call rewritten as object declaration when stack-checking is
2181          --  enabled. Propagate tag to expression in declaration, which is
2182          --  original call.
2183
2184          Call_Node := Expression (Parent (Entity (Actual)));
2185
2186       --  Ada 2005: If this is a dereference of a call to a function with a
2187       --  dispatching access-result, the tag is propagated when the dereference
2188       --  itself is expanded (see exp_ch6.adb) and there is nothing else to do.
2189
2190       elsif Nkind (Actual) = N_Explicit_Dereference
2191         and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
2192       then
2193          return;
2194
2195       --  Only other possibilities are parenthesized or qualified expression,
2196       --  or an expander-generated unchecked conversion of a function call to
2197       --  a stream Input attribute.
2198
2199       else
2200          Call_Node := Expression (Actual);
2201       end if;
2202
2203       --  Do not set the Controlling_Argument if already set. This happens in
2204       --  the special case of _Input (see Exp_Attr, case Input).
2205
2206       if No (Controlling_Argument (Call_Node)) then
2207          Set_Controlling_Argument (Call_Node, Control);
2208       end if;
2209
2210       Arg := First_Actual (Call_Node);
2211
2212       while Present (Arg) loop
2213          if Is_Tag_Indeterminate (Arg) then
2214             Propagate_Tag (Control,  Arg);
2215          end if;
2216
2217          Next_Actual (Arg);
2218       end loop;
2219
2220       --  Expansion of dispatching calls is suppressed when VM_Target, because
2221       --  the VM back-ends directly handle the generation of dispatching calls
2222       --  and would have to undo any expansion to an indirect call.
2223
2224       if Tagged_Type_Expansion then
2225          declare
2226             Call_Typ : constant Entity_Id := Etype (Call_Node);
2227
2228          begin
2229             Expand_Dispatching_Call (Call_Node);
2230
2231             --  If the controlling argument is an interface type and the type
2232             --  of Call_Node differs then we must add an implicit conversion to
2233             --  force displacement of the pointer to the object to reference
2234             --  the secondary dispatch table of the interface.
2235
2236             if Is_Interface (Etype (Control))
2237               and then Etype (Control) /= Call_Typ
2238             then
2239                --  Cannot use Convert_To because the previous call to
2240                --  Expand_Dispatching_Call leaves decorated the Call_Node
2241                --  with the type of Control.
2242
2243                Rewrite (Call_Node,
2244                  Make_Type_Conversion (Sloc (Call_Node),
2245                    Subtype_Mark =>
2246                      New_Occurrence_Of (Etype (Control), Sloc (Call_Node)),
2247                    Expression => Relocate_Node (Call_Node)));
2248                Set_Etype (Call_Node, Etype (Control));
2249                Set_Analyzed (Call_Node);
2250
2251                Expand_Interface_Conversion (Call_Node, Is_Static => False);
2252             end if;
2253          end;
2254
2255       --  Expansion of a dispatching call results in an indirect call, which in
2256       --  turn causes current values to be killed (see Resolve_Call), so on VM
2257       --  targets we do the call here to ensure consistent warnings between VM
2258       --  and non-VM targets.
2259
2260       else
2261          Kill_Current_Values;
2262       end if;
2263    end Propagate_Tag;
2264
2265 end Sem_Disp;