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-2007, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Debug;    use Debug;
  29 with Elists;   use Elists;
  30 with Einfo;    use Einfo;
  31 with Exp_Disp; use Exp_Disp;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Tss;  use Exp_Tss;
  34 with Errout;   use Errout;
  35 with Namet;    use Namet;
  36 with Nlists;   use Nlists;
  37 with Nmake;    use Nmake;
  38 with Opt;      use Opt;
  39 with Output;   use Output;
  40 with Restrict; use Restrict;
  41 with Rident;   use Rident;
  42 with Sem;      use Sem;
  43 with Sem_Ch6;  use Sem_Ch6;
  44 with Sem_Eval; use Sem_Eval;
  45 with Sem_Type; use Sem_Type;
  46 with Sem_Util; use Sem_Util;
  47 with Snames;   use Snames;
  48 with Stand;    use Stand;
  49 with Sinfo;    use Sinfo;
  50 with Targparm; use Targparm;
  51 with Tbuild;   use Tbuild;
  52 with Uintp;    use Uintp;
  53
  54 package body Sem_Disp is
  55
  56    -----------------------
  57    -- Local Subprograms --
  58    -----------------------
  59
  60    procedure Add_Dispatching_Operation
  61      (Tagged_Type : Entity_Id;
  62       New_Op      : Entity_Id);
  63    --  Add New_Op in the list of primitive operations of Tagged_Type
  64
  65    function Check_Controlling_Type
  66      (T    : Entity_Id;
  67       Subp : Entity_Id) return Entity_Id;
  68    --  T is the tagged type of a formal parameter or the result of Subp.
  69    --  If the subprogram has a controlling parameter or result that matches
  70    --  the type, then returns the tagged type of that parameter or result
  71    --  (returning the designated tagged type in the case of an access
  72    --  parameter); otherwise returns empty.
  73
  74    -------------------------------
  75    -- Add_Dispatching_Operation --
  76    -------------------------------
  77
  78    procedure Add_Dispatching_Operation
  79      (Tagged_Type : Entity_Id;
  80       New_Op      : Entity_Id)
  81    is
  82       List : constant Elist_Id := Primitive_Operations (Tagged_Type);
  83    begin
  84       Append_Elmt (New_Op, List);
  85    end Add_Dispatching_Operation;
  86
  87    -------------------------------
  88    -- Check_Controlling_Formals --
  89    -------------------------------
  90
  91    procedure Check_Controlling_Formals
  92      (Typ  : Entity_Id;
  93       Subp : Entity_Id)
  94    is
  95       Formal    : Entity_Id;
  96       Ctrl_Type : Entity_Id;
  97
  98    begin
  99       Formal := First_Formal (Subp);
 100
 101       while Present (Formal) loop
 102          Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
 103
 104          if Present (Ctrl_Type) then
 105
 106             --  When the controlling type is concurrent and declared within a
 107             --  generic or inside an instance, use its corresponding record
 108             --  type.
 109
 110             if Is_Concurrent_Type (Ctrl_Type)
 111               and then Present (Corresponding_Record_Type (Ctrl_Type))
 112             then
 113                Ctrl_Type := Corresponding_Record_Type (Ctrl_Type);
 114             end if;
 115
 116             if Ctrl_Type = Typ then
 117                Set_Is_Controlling_Formal (Formal);
 118
 119                --  Ada 2005 (AI-231): Anonymous access types used in
 120                --  controlling parameters exclude null because it is necessary
 121                --  to read the tag to dispatch, and null has no tag.
 122
 123                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
 124                   Set_Can_Never_Be_Null (Etype (Formal));
 125                   Set_Is_Known_Non_Null (Etype (Formal));
 126                end if;
 127
 128                --  Check that the parameter's nominal subtype statically
 129                --  matches the first subtype.
 130
 131                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
 132                   if not Subtypes_Statically_Match
 133                            (Typ, Designated_Type (Etype (Formal)))
 134                   then
 135                      Error_Msg_N
 136                        ("parameter subtype does not match controlling type",
 137                         Formal);
 138                   end if;
 139
 140                elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
 141                   Error_Msg_N
 142                     ("parameter subtype does not match controlling type",
 143                      Formal);
 144                end if;
 145
 146                if Present (Default_Value (Formal)) then
 147                   if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
 148                      Error_Msg_N
 149                        ("default not allowed for controlling access parameter",
 150                         Default_Value (Formal));
 151
 152                   elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then
 153                      Error_Msg_N
 154                        ("default expression must be a tag indeterminate" &
 155                         " function call", Default_Value (Formal));
 156                   end if;
 157                end if;
 158
 159             elsif Comes_From_Source (Subp) then
 160                Error_Msg_N
 161                  ("operation can be dispatching in only one type", Subp);
 162             end if;
 163          end if;
 164
 165          Next_Formal (Formal);
 166       end loop;
 167
 168       if Present (Etype (Subp)) then
 169          Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
 170
 171          if Present (Ctrl_Type) then
 172             if Ctrl_Type = Typ then
 173                Set_Has_Controlling_Result (Subp);
 174
 175                --  Check that result subtype statically matches first subtype
 176                --  (Ada 2005) : Subp may have a controlling access result.
 177
 178                if Subtypes_Statically_Match (Typ, Etype (Subp))
 179                  or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type
 180                             and then
 181                               Subtypes_Statically_Match
 182                                 (Typ, Designated_Type (Etype (Subp))))
 183                then
 184                   null;
 185
 186                else
 187                   Error_Msg_N
 188                     ("result subtype does not match controlling type", Subp);
 189                end if;
 190
 191             elsif Comes_From_Source (Subp) then
 192                Error_Msg_N
 193                  ("operation can be dispatching in only one type", Subp);
 194             end if;
 195          end if;
 196       end if;
 197    end Check_Controlling_Formals;
 198
 199    ----------------------------
 200    -- Check_Controlling_Type --
 201    ----------------------------
 202
 203    function Check_Controlling_Type
 204      (T    : Entity_Id;
 205       Subp : Entity_Id) return Entity_Id
 206    is
 207       Tagged_Type : Entity_Id := Empty;
 208
 209    begin
 210       if Is_Tagged_Type (T) then
 211          if Is_First_Subtype (T) then
 212             Tagged_Type := T;
 213          else
 214             Tagged_Type := Base_Type (T);
 215          end if;
 216
 217       elsif Ekind (T) = E_Anonymous_Access_Type
 218         and then Is_Tagged_Type (Designated_Type (T))
 219       then
 220          if Ekind (Designated_Type (T)) /= E_Incomplete_Type then
 221             if Is_First_Subtype (Designated_Type (T)) then
 222                Tagged_Type := Designated_Type (T);
 223             else
 224                Tagged_Type := Base_Type (Designated_Type (T));
 225             end if;
 226
 227          --  Ada 2005 : an incomplete type can be tagged. An operation with
 228          --  an access parameter of the type is dispatching.
 229
 230          elsif Scope (Designated_Type (T)) = Current_Scope then
 231             Tagged_Type := Designated_Type (T);
 232
 233          --  Ada 2005 (AI-50217)
 234
 235          elsif From_With_Type (Designated_Type (T))
 236            and then Present (Non_Limited_View (Designated_Type (T)))
 237          then
 238             if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then
 239                Tagged_Type := Non_Limited_View (Designated_Type (T));
 240             else
 241                Tagged_Type := Base_Type (Non_Limited_View
 242                                          (Designated_Type (T)));
 243             end if;
 244          end if;
 245       end if;
 246
 247       if No (Tagged_Type)
 248         or else Is_Class_Wide_Type (Tagged_Type)
 249       then
 250          return Empty;
 251
 252       --  The dispatching type and the primitive operation must be defined
 253       --  in the same scope, except in the case of internal operations and
 254       --  formal abstract subprograms.
 255
 256       elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp))
 257                and then (not Is_Generic_Type (Tagged_Type)
 258                           or else not Comes_From_Source (Subp)))
 259         or else
 260           (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
 261         or else
 262           (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
 263             and then
 264               Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
 265             and then
 266               Is_Abstract_Subprogram (Subp))
 267       then
 268          return Tagged_Type;
 269
 270       else
 271          return Empty;
 272       end if;
 273    end Check_Controlling_Type;
 274
 275    ----------------------------
 276    -- Check_Dispatching_Call --
 277    ----------------------------
 278
 279    procedure Check_Dispatching_Call (N : Node_Id) is
 280       Loc                    : constant Source_Ptr := Sloc (N);
 281       Actual                 : Node_Id;
 282       Formal                 : Entity_Id;
 283       Control                : Node_Id := Empty;
 284       Func                   : Entity_Id;
 285       Subp_Entity            : Entity_Id;
 286       Indeterm_Ancestor_Call : Boolean := False;
 287       Indeterm_Ctrl_Type     : Entity_Id;
 288
 289       procedure Check_Dispatching_Context;
 290       --  If the call is tag-indeterminate and the entity being called is
 291       --  abstract, verify that the context is a call that will eventually
 292       --  provide a tag for dispatching, or has provided one already.
 293
 294       -------------------------------
 295       -- Check_Dispatching_Context --
 296       -------------------------------
 297
 298       procedure Check_Dispatching_Context is
 299          Subp : constant Entity_Id := Entity (Name (N));
 300          Par  : Node_Id;
 301
 302       begin
 303          if Is_Abstract_Subprogram (Subp)
 304            and then No (Controlling_Argument (N))
 305          then
 306             if Present (Alias (Subp))
 307               and then not Is_Abstract_Subprogram (Alias (Subp))
 308               and then No (DTC_Entity (Subp))
 309             then
 310                --  Private overriding of inherited abstract operation,
 311                --  call is legal.
 312
 313                Set_Entity (Name (N), Alias (Subp));
 314                return;
 315
 316             else
 317                Par := Parent (N);
 318
 319                while Present (Par) loop
 320
 321                   if (Nkind (Par) = N_Function_Call            or else
 322                       Nkind (Par) = N_Procedure_Call_Statement or else
 323                       Nkind (Par) = N_Assignment_Statement     or else
 324                       Nkind (Par) = N_Op_Eq                    or else
 325                       Nkind (Par) = N_Op_Ne)
 326                     and then Is_Tagged_Type (Etype (Subp))
 327                   then
 328                      return;
 329
 330                   elsif Nkind (Par) = N_Qualified_Expression
 331                     or else Nkind (Par) = N_Unchecked_Type_Conversion
 332                   then
 333                      Par := Parent (Par);
 334
 335                   else
 336                      if Ekind (Subp) = E_Function then
 337                         Error_Msg_N
 338                           ("call to abstract function must be dispatching", N);
 339
 340                      --  This error can occur for a procedure in the case of a
 341                      --  call to an abstract formal procedure with a statically
 342                      --  tagged operand.
 343
 344                      else
 345                         Error_Msg_N
 346                           ("call to abstract procedure must be dispatching",
 347                            N);
 348                      end if;
 349
 350                      return;
 351                   end if;
 352                end loop;
 353             end if;
 354          end if;
 355       end Check_Dispatching_Context;
 356
 357    --  Start of processing for Check_Dispatching_Call
 358
 359    begin
 360       --  Find a controlling argument, if any
 361
 362       if Present (Parameter_Associations (N)) then
 363          Actual := First_Actual (N);
 364
 365          Subp_Entity := Entity (Name (N));
 366          Formal := First_Formal (Subp_Entity);
 367
 368          while Present (Actual) loop
 369             Control := Find_Controlling_Arg (Actual);
 370             exit when Present (Control);
 371
 372             --  Check for the case where the actual is a tag-indeterminate call
 373             --  whose result type is different than the tagged type associated
 374             --  with the containing call, but is an ancestor of the type.
 375
 376             if Is_Controlling_Formal (Formal)
 377               and then Is_Tag_Indeterminate (Actual)
 378               and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
 379               and then Is_Ancestor (Etype (Actual), Etype (Formal))
 380             then
 381                Indeterm_Ancestor_Call := True;
 382                Indeterm_Ctrl_Type     := Etype (Formal);
 383             end if;
 384
 385             Next_Actual (Actual);
 386             Next_Formal (Formal);
 387          end loop;
 388
 389          --  If the call doesn't have a controlling actual but does have
 390          --  an indeterminate actual that requires dispatching treatment,
 391          --  then an object is needed that will serve as the controlling
 392          --  argument for a dispatching call on the indeterminate actual.
 393          --  This can only occur in the unusual situation of a default
 394          --  actual given by a tag-indeterminate call and where the type
 395          --  of the call is an ancestor of the type associated with a
 396          --  containing call to an inherited operation (see AI-239).
 397          --  Rather than create an object of the tagged type, which would
 398          --  be problematic for various reasons (default initialization,
 399          --  discriminants), the tag of the containing call's associated
 400          --  tagged type is directly used to control the dispatching.
 401
 402          if No (Control)
 403            and then Indeterm_Ancestor_Call
 404          then
 405             Control :=
 406               Make_Attribute_Reference (Loc,
 407                 Prefix         => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
 408                 Attribute_Name => Name_Tag);
 409             Analyze (Control);
 410          end if;
 411
 412          if Present (Control) then
 413
 414             --  Verify that no controlling arguments are statically tagged
 415
 416             if Debug_Flag_E then
 417                Write_Str ("Found Dispatching call");
 418                Write_Int (Int (N));
 419                Write_Eol;
 420             end if;
 421
 422             Actual := First_Actual (N);
 423
 424             while Present (Actual) loop
 425                if Actual /= Control then
 426
 427                   if not Is_Controlling_Actual (Actual) then
 428                      null; -- Can be anything
 429
 430                   elsif Is_Dynamically_Tagged (Actual) then
 431                      null; -- Valid parameter
 432
 433                   elsif Is_Tag_Indeterminate (Actual) then
 434
 435                      --  The tag is inherited from the enclosing call (the
 436                      --  node we are currently analyzing). Explicitly expand
 437                      --  the actual, since the previous call to Expand
 438                      --  (from Resolve_Call) had no way of knowing about
 439                      --  the required dispatching.
 440
 441                      Propagate_Tag (Control, Actual);
 442
 443                   else
 444                      Error_Msg_N
 445                        ("controlling argument is not dynamically tagged",
 446                         Actual);
 447                      return;
 448                   end if;
 449                end if;
 450
 451                Next_Actual (Actual);
 452             end loop;
 453
 454             --  Mark call as a dispatching call
 455
 456             Set_Controlling_Argument (N, Control);
 457             Check_Restriction (No_Dispatching_Calls, N);
 458
 459          else
 460             --  The call is not dispatching, so check that there aren't any
 461             --  tag-indeterminate abstract calls left.
 462
 463             Actual := First_Actual (N);
 464
 465             while Present (Actual) loop
 466                if Is_Tag_Indeterminate (Actual) then
 467
 468                   --  Function call case
 469
 470                   if Nkind (Original_Node (Actual)) = N_Function_Call then
 471                      Func := Entity (Name (Original_Node (Actual)));
 472
 473                   --  If the actual is an attribute then it can't be abstract
 474                   --  (the only current case of a tag-indeterminate attribute
 475                   --  is the stream Input attribute).
 476
 477                   elsif
 478                     Nkind (Original_Node (Actual)) = N_Attribute_Reference
 479                   then
 480                      Func := Empty;
 481
 482                   --  Only other possibility is a qualified expression whose
 483                   --  constituent expression is itself a call.
 484
 485                   else
 486                      Func :=
 487                        Entity (Name
 488                          (Original_Node
 489                            (Expression (Original_Node (Actual)))));
 490                   end if;
 491
 492                   if Present (Func) and then Is_Abstract_Subprogram (Func) then
 493                      Error_Msg_N (
 494                        "call to abstract function must be dispatching", N);
 495                   end if;
 496                end if;
 497
 498                Next_Actual (Actual);
 499             end loop;
 500
 501             Check_Dispatching_Context;
 502          end if;
 503
 504       else
 505          --  If dispatching on result, the enclosing call, if any, will
 506          --  determine the controlling argument. Otherwise this is the
 507          --  primitive operation of the root type.
 508
 509          Check_Dispatching_Context;
 510       end if;
 511    end Check_Dispatching_Call;
 512
 513    ---------------------------------
 514    -- Check_Dispatching_Operation --
 515    ---------------------------------
 516
 517    procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
 518       Tagged_Type            : Entity_Id;
 519       Has_Dispatching_Parent : Boolean := False;
 520       Body_Is_Last_Primitive : Boolean := False;
 521
 522       function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
 523       --  Check whether T is derived from a visibly controlled type.
 524       --  This is true if the root type is declared in Ada.Finalization.
 525       --  If T is derived instead from a private type whose full view
 526       --  is controlled, an explicit Initialize/Adjust/Finalize subprogram
 527       --  does not override the inherited one.
 528
 529       ---------------------------
 530       -- Is_Visibly_Controlled --
 531       ---------------------------
 532
 533       function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
 534          Root : constant Entity_Id := Root_Type (T);
 535       begin
 536          return Chars (Scope (Root)) = Name_Finalization
 537            and then Chars (Scope (Scope (Root))) = Name_Ada
 538            and then Scope (Scope (Scope (Root))) = Standard_Standard;
 539       end Is_Visibly_Controlled;
 540
 541    --  Start of processing for Check_Dispatching_Operation
 542
 543    begin
 544       if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
 545          return;
 546       end if;
 547
 548       Set_Is_Dispatching_Operation (Subp, False);
 549       Tagged_Type := Find_Dispatching_Type (Subp);
 550
 551       --  Ada 2005 (AI-345)
 552
 553       if Ada_Version = Ada_05
 554         and then Present (Tagged_Type)
 555         and then Is_Concurrent_Type (Tagged_Type)
 556       then
 557          --  Protect the frontend against previously detected errors
 558
 559          if No (Corresponding_Record_Type (Tagged_Type)) then
 560             return;
 561          end if;
 562
 563          Tagged_Type := Corresponding_Record_Type (Tagged_Type);
 564       end if;
 565
 566       --  If Subp is derived from a dispatching operation then it should
 567       --  always be treated as dispatching. In this case various checks
 568       --  below will be bypassed. Makes sure that late declarations for
 569       --  inherited private subprograms are treated as dispatching, even
 570       --  if the associated tagged type is already frozen.
 571
 572       Has_Dispatching_Parent :=
 573          Present (Alias (Subp))
 574            and then Is_Dispatching_Operation (Alias (Subp));
 575
 576       if No (Tagged_Type) then
 577
 578          --  Ada 2005 (AI-251): Check that Subp is not a primitive associated
 579          --  with an abstract interface type unless the interface acts as a
 580          --  parent type in a derivation. If the interface type is a formal
 581          --  type then the operation is not primitive and therefore legal.
 582
 583          declare
 584             E   : Entity_Id;
 585             Typ : Entity_Id;
 586
 587          begin
 588             E := First_Entity (Subp);
 589             while Present (E) loop
 590                if Is_Access_Type (Etype (E)) then
 591                   Typ := Designated_Type (Etype (E));
 592                else
 593                   Typ := Etype (E);
 594                end if;
 595
 596                if not Is_Class_Wide_Type (Typ)
 597                  and then Is_Interface (Typ)
 598                  and then not Is_Derived_Type (Typ)
 599                  and then not Is_Generic_Type (Typ)
 600                  and then not In_Instance
 601                then
 602                   Error_Msg_N ("?declaration of& is too late!", Subp);
 603                   Error_Msg_NE
 604                     ("\spec should appear immediately after declaration of &!",
 605                      Subp, Typ);
 606                   exit;
 607                end if;
 608
 609                Next_Entity (E);
 610             end loop;
 611
 612             --  In case of functions check also the result type
 613
 614             if Ekind (Subp) = E_Function then
 615                if Is_Access_Type (Etype (Subp)) then
 616                   Typ := Designated_Type (Etype (Subp));
 617                else
 618                   Typ := Etype (Subp);
 619                end if;
 620
 621                if not Is_Class_Wide_Type (Typ)
 622                  and then Is_Interface (Typ)
 623                  and then not Is_Derived_Type (Typ)
 624                then
 625                   Error_Msg_N ("?declaration of& is too late!", Subp);
 626                   Error_Msg_NE
 627                     ("\spec should appear immediately after declaration of &!",
 628                      Subp, Typ);
 629                end if;
 630             end if;
 631          end;
 632
 633          return;
 634
 635       --  The subprograms build internally after the freezing point (such as
 636       --  the Init procedure) are not primitives
 637
 638       elsif Is_Frozen (Tagged_Type)
 639         and then not Comes_From_Source (Subp)
 640         and then not Has_Dispatching_Parent
 641       then
 642          return;
 643
 644       --  The operation may be a child unit, whose scope is the defining
 645       --  package, but which is not a primitive operation of the type.
 646
 647       elsif Is_Child_Unit (Subp) then
 648          return;
 649
 650       --  If the subprogram is not defined in a package spec, the only case
 651       --  where it can be a dispatching op is when it overrides an operation
 652       --  before the freezing point of the type.
 653
 654       elsif ((not Is_Package_Or_Generic_Package (Scope (Subp)))
 655                or else In_Package_Body (Scope (Subp)))
 656         and then not Has_Dispatching_Parent
 657       then
 658          if not Comes_From_Source (Subp)
 659            or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type))
 660          then
 661             null;
 662
 663          --  If the type is already frozen, the overriding is not allowed
 664          --  except when Old_Subp is not a dispatching operation (which
 665          --  can occur when Old_Subp was inherited by an untagged type).
 666          --  However, a body with no previous spec freezes the type "after"
 667          --  its declaration, and therefore is a legal overriding (unless
 668          --  the type has already been frozen). Only the first such body
 669          --  is legal.
 670
 671          elsif Present (Old_Subp)
 672            and then Is_Dispatching_Operation (Old_Subp)
 673          then
 674             if Comes_From_Source (Subp)
 675               and then
 676                 (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body
 677                   or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub)
 678             then
 679                declare
 680                   Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
 681                   Decl_Item : Node_Id          := Next (Parent (Tagged_Type));
 682
 683                begin
 684                   --  ??? The checks here for whether the type has been
 685                   --  frozen prior to the new body are not complete. It's
 686                   --  not simple to check frozenness at this point since
 687                   --  the body has already caused the type to be prematurely
 688                   --  frozen in Analyze_Declarations, but we're forced to
 689                   --  recheck this here because of the odd rule interpretation
 690                   --  that allows the overriding if the type wasn't frozen
 691                   --  prior to the body. The freezing action should probably
 692                   --  be delayed until after the spec is seen, but that's
 693                   --  a tricky change to the delicate freezing code.
 694
 695                   --  Look at each declaration following the type up
 696                   --  until the new subprogram body. If any of the
 697                   --  declarations is a body then the type has been
 698                   --  frozen already so the overriding primitive is
 699                   --  illegal.
 700
 701                   while Present (Decl_Item)
 702                     and then (Decl_Item /= Subp_Body)
 703                   loop
 704                      if Comes_From_Source (Decl_Item)
 705                        and then (Nkind (Decl_Item) in N_Proper_Body
 706                                   or else Nkind (Decl_Item) in N_Body_Stub)
 707                      then
 708                         Error_Msg_N ("overriding of& is too late!", Subp);
 709                         Error_Msg_N
 710                           ("\spec should appear immediately after the type!",
 711                            Subp);
 712                         exit;
 713                      end if;
 714
 715                      Next (Decl_Item);
 716                   end loop;
 717
 718                   --  If the subprogram doesn't follow in the list of
 719                   --  declarations including the type then the type
 720                   --  has definitely been frozen already and the body
 721                   --  is illegal.
 722
 723                   if No (Decl_Item) then
 724                      Error_Msg_N ("overriding of& is too late!", Subp);
 725                      Error_Msg_N
 726                        ("\spec should appear immediately after the type!",
 727                         Subp);
 728
 729                   elsif Is_Frozen (Subp) then
 730
 731                      --  The subprogram body declares a primitive operation.
 732                      --  if the subprogram is already frozen, we must update
 733                      --  its dispatching information explicitly here. The
 734                      --  information is taken from the overridden subprogram.
 735
 736                      Body_Is_Last_Primitive := True;
 737
 738                      if Present (DTC_Entity (Old_Subp)) then
 739                         Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
 740                         Set_DT_Position (Subp, DT_Position (Old_Subp));
 741
 742                         if not Restriction_Active (No_Dispatching_Calls) then
 743                            Register_Primitive (Sloc (Subp_Body),
 744                              Prim    => Subp,
 745                              Ins_Nod => Subp_Body);
 746                         end if;
 747                      end if;
 748                   end if;
 749                end;
 750
 751             else
 752                Error_Msg_N ("overriding of& is too late!", Subp);
 753                Error_Msg_N
 754                  ("\subprogram spec should appear immediately after the type!",
 755                   Subp);
 756             end if;
 757
 758          --  If the type is not frozen yet and we are not in the overriding
 759          --  case it looks suspiciously like an attempt to define a primitive
 760          --  operation.
 761
 762          elsif not Is_Frozen (Tagged_Type) then
 763             Error_Msg_N
 764               ("?not dispatching (must be defined in a package spec)", Subp);
 765             return;
 766
 767          --  When the type is frozen, it is legitimate to define a new
 768          --  non-primitive operation.
 769
 770          else
 771             return;
 772          end if;
 773
 774       --  Now, we are sure that the scope is a package spec. If the subprogram
 775       --  is declared after the freezing point of the type that's an error
 776
 777       elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
 778          Error_Msg_N ("this primitive operation is declared too late", Subp);
 779          Error_Msg_NE
 780            ("?no primitive operations for& after this line",
 781             Freeze_Node (Tagged_Type),
 782             Tagged_Type);
 783          return;
 784       end if;
 785
 786       Check_Controlling_Formals (Tagged_Type, Subp);
 787
 788       --  Now it should be a correct primitive operation, put it in the list
 789
 790       if Present (Old_Subp) then
 791          Check_Subtype_Conformant (Subp, Old_Subp);
 792          if (Chars (Subp) = Name_Initialize
 793            or else Chars (Subp) = Name_Adjust
 794            or else Chars (Subp) = Name_Finalize)
 795            and then Is_Controlled (Tagged_Type)
 796            and then not Is_Visibly_Controlled (Tagged_Type)
 797          then
 798             Set_Is_Overriding_Operation (Subp, False);
 799             Error_Msg_NE
 800               ("operation does not override inherited&?", Subp, Subp);
 801          else
 802             Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
 803             Set_Is_Overriding_Operation (Subp);
 804
 805             --  Ada 2005 (AI-251): In case of late overriding of a primitive
 806             --  that covers abstract interface subprograms we must register it
 807             --  in all the secondary dispatch tables associated with abstract
 808             --  interfaces.
 809
 810             if Body_Is_Last_Primitive then
 811                declare
 812                   Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
 813                   Elmt      : Elmt_Id;
 814                   Prim      : Node_Id;
 815
 816                begin
 817                   Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
 818                   while Present (Elmt) loop
 819                      Prim := Node (Elmt);
 820
 821                      if Present (Alias (Prim))
 822                        and then Present (Abstract_Interface_Alias (Prim))
 823                        and then Alias (Prim) = Subp
 824                      then
 825                         Register_Primitive (Sloc (Prim),
 826                           Prim    => Prim,
 827                           Ins_Nod => Subp_Body);
 828                      end if;
 829
 830                      Next_Elmt (Elmt);
 831                   end loop;
 832
 833                   --  Redisplay the contents of the updated dispatch table
 834
 835                   if Debug_Flag_ZZ then
 836                      Write_Str ("Late overriding: ");
 837                      Write_DT (Tagged_Type);
 838                   end if;
 839                end;
 840             end if;
 841          end if;
 842
 843       --  If no old subprogram, then we add this as a dispatching operation,
 844       --  but we avoid doing this if an error was posted, to prevent annoying
 845       --  cascaded errors.
 846
 847       elsif not Error_Posted (Subp) then
 848          Add_Dispatching_Operation (Tagged_Type, Subp);
 849       end if;
 850
 851       Set_Is_Dispatching_Operation (Subp, True);
 852
 853       if not Body_Is_Last_Primitive then
 854          Set_DT_Position (Subp, No_Uint);
 855
 856       elsif Has_Controlled_Component (Tagged_Type)
 857         and then
 858          (Chars (Subp) = Name_Initialize
 859            or else Chars (Subp) = Name_Adjust
 860            or else Chars (Subp) = Name_Finalize)
 861       then
 862          declare
 863             F_Node   : constant Node_Id := Freeze_Node (Tagged_Type);
 864             Decl     : Node_Id;
 865             Old_P    : Entity_Id;
 866             Old_Bod  : Node_Id;
 867             Old_Spec : Entity_Id;
 868
 869             C_Names : constant array (1 .. 3) of Name_Id :=
 870                         (Name_Initialize,
 871                          Name_Adjust,
 872                          Name_Finalize);
 873
 874             D_Names : constant array (1 .. 3) of TSS_Name_Type :=
 875                         (TSS_Deep_Initialize,
 876                          TSS_Deep_Adjust,
 877                          TSS_Deep_Finalize);
 878
 879          begin
 880             --  Remove previous controlled function, which was constructed
 881             --  and analyzed when the type was frozen. This requires
 882             --  removing the body of the redefined primitive, as well as
 883             --  its specification if needed (there is no spec created for
 884             --  Deep_Initialize, see exp_ch3.adb). We must also dismantle
 885             --  the exception information that may have been generated for
 886             --  it when front end zero-cost tables are enabled.
 887
 888             for J in D_Names'Range loop
 889                Old_P := TSS (Tagged_Type, D_Names (J));
 890
 891                if Present (Old_P)
 892                 and then Chars (Subp) = C_Names (J)
 893                then
 894                   Old_Bod := Unit_Declaration_Node (Old_P);
 895                   Remove (Old_Bod);
 896                   Set_Is_Eliminated (Old_P);
 897                   Set_Scope (Old_P,  Scope (Current_Scope));
 898
 899                   if Nkind (Old_Bod) = N_Subprogram_Body
 900                     and then Present (Corresponding_Spec (Old_Bod))
 901                   then
 902                      Old_Spec := Corresponding_Spec (Old_Bod);
 903                      Set_Has_Completion             (Old_Spec, False);
 904                   end if;
 905                end if;
 906             end loop;
 907
 908             Build_Late_Proc (Tagged_Type, Chars (Subp));
 909
 910             --  The new operation is added to the actions of the freeze
 911             --  node for the type, but this node has already been analyzed,
 912             --  so we must retrieve and analyze explicitly the new body.
 913
 914             if Present (F_Node)
 915               and then Present (Actions (F_Node))
 916             then
 917                Decl := Last (Actions (F_Node));
 918                Analyze (Decl);
 919             end if;
 920          end;
 921       end if;
 922    end Check_Dispatching_Operation;
 923
 924    ------------------------------------------
 925    -- Check_Operation_From_Incomplete_Type --
 926    ------------------------------------------
 927
 928    procedure Check_Operation_From_Incomplete_Type
 929      (Subp : Entity_Id;
 930       Typ  : Entity_Id)
 931    is
 932       Full       : constant Entity_Id := Full_View (Typ);
 933       Parent_Typ : constant Entity_Id := Etype (Full);
 934       Old_Prim   : constant Elist_Id  := Primitive_Operations (Parent_Typ);
 935       New_Prim   : constant Elist_Id  := Primitive_Operations (Full);
 936       Op1, Op2   : Elmt_Id;
 937       Prev       : Elmt_Id := No_Elmt;
 938
 939       function Derives_From (Proc : Entity_Id) return Boolean;
 940       --  Check that Subp has the signature of an operation derived from Proc.
 941       --  Subp has an access parameter that designates Typ.
 942
 943       ------------------
 944       -- Derives_From --
 945       ------------------
 946
 947       function Derives_From (Proc : Entity_Id) return Boolean is
 948          F1, F2 : Entity_Id;
 949
 950       begin
 951          if Chars (Proc) /= Chars (Subp) then
 952             return False;
 953          end if;
 954
 955          F1 := First_Formal (Proc);
 956          F2 := First_Formal (Subp);
 957
 958          while Present (F1) and then Present (F2) loop
 959
 960             if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
 961
 962                if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
 963                   return False;
 964
 965                elsif Designated_Type (Etype (F1)) = Parent_Typ
 966                  and then Designated_Type (Etype (F2)) /= Full
 967                then
 968                   return False;
 969                end if;
 970
 971             elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then
 972                return False;
 973
 974             elsif Etype (F1) /= Etype (F2) then
 975                return False;
 976             end if;
 977
 978             Next_Formal (F1);
 979             Next_Formal (F2);
 980          end loop;
 981
 982          return No (F1) and then No (F2);
 983       end Derives_From;
 984
 985    --  Start of processing for Check_Operation_From_Incomplete_Type
 986
 987    begin
 988       --  The operation may override an inherited one, or may be a new one
 989       --  altogether. The inherited operation will have been hidden by the
 990       --  current one at the point of the type derivation, so it does not
 991       --  appear in the list of primitive operations of the type. We have to
 992       --  find the proper place of insertion in the list of primitive opera-
 993       --  tions by iterating over the list for the parent type.
 994
 995       Op1 := First_Elmt (Old_Prim);
 996       Op2 := First_Elmt (New_Prim);
 997
 998       while Present (Op1) and then Present (Op2) loop
 999
1000          if Derives_From (Node (Op1)) then
1001
1002             if No (Prev) then
1003                Prepend_Elmt (Subp, New_Prim);
1004             else
1005                Insert_Elmt_After (Subp, Prev);
1006             end if;
1007
1008             return;
1009          end if;
1010
1011          Prev := Op2;
1012          Next_Elmt (Op1);
1013          Next_Elmt (Op2);
1014       end loop;
1015
1016       --  Operation is a new primitive
1017
1018       Append_Elmt (Subp, New_Prim);
1019    end Check_Operation_From_Incomplete_Type;
1020
1021    ---------------------------------------
1022    -- Check_Operation_From_Private_View --
1023    ---------------------------------------
1024
1025    procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is
1026       Tagged_Type : Entity_Id;
1027
1028    begin
1029       if Is_Dispatching_Operation (Alias (Subp)) then
1030          Set_Scope (Subp, Current_Scope);
1031          Tagged_Type := Find_Dispatching_Type (Subp);
1032
1033          if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
1034             Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
1035
1036             --  If Old_Subp isn't already marked as dispatching then
1037             --  this is the case of an operation of an untagged private
1038             --  type fulfilled by a tagged type that overrides an
1039             --  inherited dispatching operation, so we set the necessary
1040             --  dispatching attributes here.
1041
1042             if not Is_Dispatching_Operation (Old_Subp) then
1043
1044                --  If the untagged type has no discriminants, and the full
1045                --  view is constrained, there will be a spurious mismatch
1046                --  of subtypes on the controlling arguments, because the tagged
1047                --  type is the internal base type introduced in the derivation.
1048                --  Use the original type to verify conformance, rather than the
1049                --  base type.
1050
1051                if not Comes_From_Source (Tagged_Type)
1052                  and then Has_Discriminants (Tagged_Type)
1053                then
1054                   declare
1055                      Formal : Entity_Id;
1056                   begin
1057                      Formal := First_Formal (Old_Subp);
1058                      while Present (Formal) loop
1059                         if Tagged_Type = Base_Type (Etype (Formal)) then
1060                            Tagged_Type := Etype (Formal);
1061                         end if;
1062
1063                         Next_Formal (Formal);
1064                      end loop;
1065                   end;
1066
1067                   if Tagged_Type = Base_Type (Etype (Old_Subp)) then
1068                      Tagged_Type := Etype (Old_Subp);
1069                   end if;
1070                end if;
1071
1072                Check_Controlling_Formals (Tagged_Type, Old_Subp);
1073                Set_Is_Dispatching_Operation (Old_Subp, True);
1074                Set_DT_Position (Old_Subp, No_Uint);
1075             end if;
1076
1077             --  If the old subprogram is an explicit renaming of some other
1078             --  entity, it is not overridden by the inherited subprogram.
1079             --  Otherwise, update its alias and other attributes.
1080
1081             if Present (Alias (Old_Subp))
1082               and then Nkind (Unit_Declaration_Node (Old_Subp))
1083                 /= N_Subprogram_Renaming_Declaration
1084             then
1085                Set_Alias (Old_Subp, Alias (Subp));
1086
1087                --  The derived subprogram should inherit the abstractness
1088                --  of the parent subprogram (except in the case of a function
1089                --  returning the type). This sets the abstractness properly
1090                --  for cases where a private extension may have inherited
1091                --  an abstract operation, but the full type is derived from
1092                --  a descendant type and inherits a nonabstract version.
1093
1094                if Etype (Subp) /= Tagged_Type then
1095                   Set_Is_Abstract_Subprogram
1096                     (Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
1097                end if;
1098             end if;
1099          end if;
1100       end if;
1101    end Check_Operation_From_Private_View;
1102
1103    --------------------------
1104    -- Find_Controlling_Arg --
1105    --------------------------
1106
1107    function Find_Controlling_Arg (N : Node_Id) return Node_Id is
1108       Orig_Node : constant Node_Id := Original_Node (N);
1109       Typ       : Entity_Id;
1110
1111    begin
1112       if Nkind (Orig_Node) = N_Qualified_Expression then
1113          return Find_Controlling_Arg (Expression (Orig_Node));
1114       end if;
1115
1116       --  Dispatching on result case
1117
1118       if Nkind (Orig_Node) = N_Function_Call
1119         and then Present (Controlling_Argument (Orig_Node))
1120         and then Has_Controlling_Result (Entity (Name (Orig_Node)))
1121       then
1122          return Controlling_Argument (Orig_Node);
1123
1124       --  Normal case
1125
1126       elsif Is_Controlling_Actual (N)
1127         or else
1128          (Nkind (Parent (N)) = N_Qualified_Expression
1129            and then Is_Controlling_Actual (Parent (N)))
1130       then
1131          Typ := Etype (N);
1132
1133          if Is_Access_Type (Typ) then
1134             --  In the case of an Access attribute, use the type of
1135             --  the prefix, since in the case of an actual for an
1136             --  access parameter, the attribute's type may be of a
1137             --  specific designated type, even though the prefix
1138             --  type is class-wide.
1139
1140             if Nkind (N) = N_Attribute_Reference then
1141                Typ := Etype (Prefix (N));
1142
1143             --  An allocator is dispatching if the type of qualified
1144             --  expression is class_wide, in which case this is the
1145             --  controlling type.
1146
1147             elsif Nkind (Orig_Node) = N_Allocator
1148                and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
1149             then
1150                Typ := Etype (Expression (Orig_Node));
1151
1152             else
1153                Typ := Designated_Type (Typ);
1154             end if;
1155          end if;
1156
1157          if Is_Class_Wide_Type (Typ)
1158            or else
1159              (Nkind (Parent (N)) = N_Qualified_Expression
1160                and then Is_Access_Type (Etype (N))
1161                and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
1162          then
1163             return N;
1164          end if;
1165       end if;
1166
1167       return Empty;
1168    end Find_Controlling_Arg;
1169
1170    ---------------------------
1171    -- Find_Dispatching_Type --
1172    ---------------------------
1173
1174    function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
1175       Formal    : Entity_Id;
1176       Ctrl_Type : Entity_Id;
1177
1178    begin
1179       if Present (DTC_Entity (Subp)) then
1180          return Scope (DTC_Entity (Subp));
1181
1182       else
1183          Formal := First_Formal (Subp);
1184          while Present (Formal) loop
1185             Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
1186
1187             if Present (Ctrl_Type) then
1188                return Ctrl_Type;
1189             end if;
1190
1191             Next_Formal (Formal);
1192          end loop;
1193
1194       --  The subprogram may also be dispatching on result
1195
1196          if Present (Etype (Subp)) then
1197             Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
1198
1199             if Present (Ctrl_Type) then
1200                return Ctrl_Type;
1201             end if;
1202          end if;
1203       end if;
1204
1205       return Empty;
1206    end Find_Dispatching_Type;
1207
1208    ---------------------------
1209    -- Is_Dynamically_Tagged --
1210    ---------------------------
1211
1212    function Is_Dynamically_Tagged (N : Node_Id) return Boolean is
1213    begin
1214       return Find_Controlling_Arg (N) /= Empty;
1215    end Is_Dynamically_Tagged;
1216
1217    --------------------------
1218    -- Is_Tag_Indeterminate --
1219    --------------------------
1220
1221    function Is_Tag_Indeterminate (N : Node_Id) return Boolean is
1222       Nam       : Entity_Id;
1223       Actual    : Node_Id;
1224       Orig_Node : constant Node_Id := Original_Node (N);
1225
1226    begin
1227       if Nkind (Orig_Node) = N_Function_Call
1228         and then Is_Entity_Name (Name (Orig_Node))
1229       then
1230          Nam := Entity (Name (Orig_Node));
1231
1232          if not Has_Controlling_Result (Nam) then
1233             return False;
1234
1235          --  An explicit dereference means that the call has already been
1236          --  expanded and there is no tag to propagate.
1237
1238          elsif Nkind (N) = N_Explicit_Dereference then
1239             return False;
1240
1241          --  If there are no actuals, the call is tag-indeterminate
1242
1243          elsif No (Parameter_Associations (Orig_Node)) then
1244             return True;
1245
1246          else
1247             Actual := First_Actual (Orig_Node);
1248             while Present (Actual) loop
1249                if Is_Controlling_Actual (Actual)
1250                  and then not Is_Tag_Indeterminate (Actual)
1251                then
1252                   return False; -- one operand is dispatching
1253                end if;
1254
1255                Next_Actual (Actual);
1256             end loop;
1257
1258             return True;
1259          end if;
1260
1261       elsif Nkind (Orig_Node) = N_Qualified_Expression then
1262          return Is_Tag_Indeterminate (Expression (Orig_Node));
1263
1264       --  Case of a call to the Input attribute (possibly rewritten), which is
1265       --  always tag-indeterminate except when its prefix is a Class attribute.
1266
1267       elsif Nkind (Orig_Node) = N_Attribute_Reference
1268         and then
1269           Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
1270         and then
1271           Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
1272       then
1273          return True;
1274
1275       --  In Ada 2005 a function that returns an anonymous access type can
1276       --  dispatching, and the dereference of a call to such a function
1277       --  is also tag-indeterminate.
1278
1279       elsif Nkind (Orig_Node) = N_Explicit_Dereference
1280         and then Ada_Version >= Ada_05
1281       then
1282          return Is_Tag_Indeterminate (Prefix (Orig_Node));
1283
1284       else
1285          return False;
1286       end if;
1287    end Is_Tag_Indeterminate;
1288
1289    ------------------------------------
1290    -- Override_Dispatching_Operation --
1291    ------------------------------------
1292
1293    procedure Override_Dispatching_Operation
1294      (Tagged_Type : Entity_Id;
1295       Prev_Op     : Entity_Id;
1296       New_Op      : Entity_Id)
1297    is
1298       Elmt : Elmt_Id;
1299       Prim : Node_Id;
1300
1301    begin
1302       --  Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
1303       --  we do it unconditionally in Ada 95 now, since this is our pragma!)
1304
1305       if No_Return (Prev_Op) and then not No_Return (New_Op) then
1306          Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
1307          Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
1308       end if;
1309
1310       --  If there is no previous operation to override, the type declaration
1311       --  was malformed, and an error must have been emitted already.
1312
1313       Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1314       while Present (Elmt)
1315         and then Node (Elmt) /= Prev_Op
1316       loop
1317          Next_Elmt (Elmt);
1318       end loop;
1319
1320       if No (Elmt) then
1321          return;
1322       end if;
1323
1324       Replace_Elmt (Elmt, New_Op);
1325
1326       if Ada_Version >= Ada_05
1327         and then Has_Abstract_Interfaces (Tagged_Type)
1328       then
1329          --  Ada 2005 (AI-251): Update the attribute alias of all the aliased
1330          --  entities of the overridden primitive to reference New_Op, and also
1331          --  propagate them the new value of the attribute
1332          --  Is_Abstract_Subprogram.
1333
1334          Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
1335          while Present (Elmt) loop
1336             Prim := Node (Elmt);
1337
1338             if Prim = New_Op then
1339                null;
1340
1341             elsif Present (Abstract_Interface_Alias (Prim))
1342               and then Alias (Prim) = Prev_Op
1343             then
1344                Set_Alias (Prim, New_Op);
1345                Set_Is_Abstract_Subprogram
1346                  (Prim, Is_Abstract_Subprogram (New_Op));
1347
1348                --  Ensure that this entity will be expanded to fill the
1349                --  corresponding entry in its dispatch table.
1350
1351                if not Is_Abstract_Subprogram (Prim) then
1352                   Set_Has_Delayed_Freeze (Prim);
1353                end if;
1354             end if;
1355
1356             Next_Elmt (Elmt);
1357          end loop;
1358       end if;
1359
1360       if (not Is_Package_Or_Generic_Package (Current_Scope))
1361         or else not In_Private_Part (Current_Scope)
1362       then
1363          --  Not a private primitive
1364
1365          null;
1366
1367       else pragma Assert (Is_Inherited_Operation (Prev_Op));
1368
1369          --  Make the overriding operation into an alias of the implicit one.
1370          --  In this fashion a call from outside ends up calling the new body
1371          --  even if non-dispatching, and a call from inside calls the
1372          --  overriding operation because it hides the implicit one. To
1373          --  indicate that the body of Prev_Op is never called, set its
1374          --  dispatch table entity to Empty.
1375
1376          Set_Alias (Prev_Op, New_Op);
1377          Set_DTC_Entity (Prev_Op, Empty);
1378          return;
1379       end if;
1380    end Override_Dispatching_Operation;
1381
1382    -------------------
1383    -- Propagate_Tag --
1384    -------------------
1385
1386    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is
1387       Call_Node : Node_Id;
1388       Arg       : Node_Id;
1389
1390    begin
1391       if Nkind (Actual) = N_Function_Call then
1392          Call_Node := Actual;
1393
1394       elsif Nkind (Actual) = N_Identifier
1395         and then Nkind (Original_Node (Actual)) = N_Function_Call
1396       then
1397          --  Call rewritten as object declaration when stack-checking
1398          --  is enabled. Propagate tag to expression in declaration, which
1399          --  is original call.
1400
1401          Call_Node := Expression (Parent (Entity (Actual)));
1402
1403       --  Ada 2005: If this is a dereference of a call to a function with a
1404       --  dispatching access-result, the tag is propagated when the dereference
1405       --  itself is expanded (see exp_ch6.adb) and there is nothing else to do.
1406
1407       elsif Nkind (Actual) = N_Explicit_Dereference
1408         and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
1409       then
1410          return;
1411
1412       --  Only other possibilities are parenthesized or qualified expression,
1413       --  or an expander-generated unchecked conversion of a function call to
1414       --  a stream Input attribute.
1415
1416       else
1417          Call_Node := Expression (Actual);
1418       end if;
1419
1420       --  Do not set the Controlling_Argument if already set. This happens
1421       --  in the special case of _Input (see Exp_Attr, case Input).
1422
1423       if No (Controlling_Argument (Call_Node)) then
1424          Set_Controlling_Argument (Call_Node, Control);
1425       end if;
1426
1427       Arg := First_Actual (Call_Node);
1428
1429       while Present (Arg) loop
1430          if Is_Tag_Indeterminate (Arg) then
1431             Propagate_Tag (Control,  Arg);
1432          end if;
1433
1434          Next_Actual (Arg);
1435       end loop;
1436
1437       --  Expansion of dispatching calls is suppressed when VM_Target, because
1438       --  the VM back-ends directly handle the generation of dispatching
1439       --  calls and would have to undo any expansion to an indirect call.
1440
1441       if VM_Target = No_VM then
1442          Expand_Dispatching_Call (Call_Node);
1443       end if;
1444    end Propagate_Tag;
1445
1446 end Sem_Disp;