gcc/ada/sem_disp.adb

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