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