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