gcc/ada/sem_disp.adb

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