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